content: {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE BangPatterns, RankNTypes, ScopedTypeVariables, CPP #-}
  -- | This "Parser" module takes a filename and its contents as a
  -- bytestring, and uses Lexer.hs to make a stream of tokens that it
  -- parses. No IO is performed and the error function is not used.
  -- Since the Lexer should also avoid such errors this should be a
  -- reliably total function of the input.
  --
  -- The internals have been updated to handle Google's protobuf version
  -- 2.0.3 formats, including EnumValueOptions.
  module Text.ProtocolBuffers.ProtoCompile.Parser(parseProto,isValidPacked) where
  
  import qualified Text.DescriptorProtos.DescriptorProto                as D(DescriptorProto)
  import qualified Text.DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))
  -- import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange)
  import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))
  import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto)
  import qualified Text.DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..))
  -- import qualified Text.DescriptorProtos.EnumOptions                    as D(EnumOptions)
  import qualified Text.DescriptorProtos.EnumOptions                    as D.EnumOptions(EnumOptions(..))
  import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D(EnumValueDescriptorProto)
  import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))
  -- import qualified Text.DescriptorProtos.EnumValueOptions               as D(EnumValueOptions)
  import qualified Text.DescriptorProtos.EnumValueOptions               as D.EnumValueOptions(EnumValueOptions(..))
  import qualified Text.DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto)
  import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..))
  import           Text.DescriptorProtos.FieldDescriptorProto.Label
  -- import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type)
  import           Text.DescriptorProtos.FieldDescriptorProto.Type         (Type(..))
  -- import qualified Text.DescriptorProtos.FieldOptions                   as D(FieldOptions)
  import qualified Text.DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))
  import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto)
  import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..))
  -- import qualified Text.DescriptorProtos.FileOptions                    as D(FileOptions)
  import qualified Text.DescriptorProtos.FileOptions                    as D.FileOptions(FileOptions(..))
  -- import qualified Text.DescriptorProtos.MessageOptions                 as D(MessageOptions)
  import qualified Text.DescriptorProtos.MessageOptions                 as D.MessageOptions(MessageOptions(..))
  import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto)
  import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..))
  -- import qualified Text.DescriptorProtos.MethodOptions                  as D(MethodOptions)
  import qualified Text.DescriptorProtos.MethodOptions                  as D.MethodOptions(MethodOptions(..))
  import qualified Text.DescriptorProtos.OneofDescriptorProto           as D(OneofDescriptorProto)
  import qualified Text.DescriptorProtos.OneofDescriptorProto           as D.OneofDescriptorProto(OneofDescriptorProto(..))
  import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D(ServiceDescriptorProto)
  import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D.ServiceDescriptorProto(ServiceDescriptorProto(..))
  -- import qualified Text.DescriptorProtos.ServiceOptions                 as D(ServiceOptions)
  import qualified Text.DescriptorProtos.ServiceOptions                 as D.ServiceOptions(ServiceOptions(..))
  import qualified Text.DescriptorProtos.UninterpretedOption            as D(UninterpretedOption)
  import qualified Text.DescriptorProtos.UninterpretedOption            as D.UninterpretedOption(UninterpretedOption(..))
  -- import qualified Text.DescriptorProtos.UninterpretedOption.NamePart   as D(NamePart)
  import qualified Text.DescriptorProtos.UninterpretedOption.NamePart   as D.NamePart(NamePart(..))
  
  import Text.ProtocolBuffers.Basic
  import Text.ProtocolBuffers.Identifiers
  import Text.ProtocolBuffers.Header(ReflectEnum(reflectEnumInfo),enumName)
  import Text.ProtocolBuffers.ProtoCompile.Lexer(Lexed(..),alexScanTokens,getLinePos)
  import Text.ProtocolBuffers.ProtoCompile.Instances(parseLabel,parseType)
  -- import Text.ProtocolBuffers.Reflections()
  
  import Control.Monad(when,liftM2,liftM3)
  import qualified Data.ByteString.Lazy as L(unpack)
  import qualified Data.ByteString.Lazy.Char8 as LC(notElem,head)
  import qualified Data.ByteString.Lazy.UTF8 as U(fromString,toString)
  import Data.Char(isUpper,toLower)
  import Data.Ix(inRange)
  import Data.Maybe(fromMaybe)
  import Data.Sequence((|>),(><))
  import qualified Data.Sequence as Seq(fromList,length,empty)
  import Data.Word(Word8)
  import Numeric(showOct)
  --import System.FilePath(takeFileName)
  import Text.ParserCombinators.Parsec(GenParser,ParseError,runParser,sourceName,anyToken,many1,lookAhead,try
                                      ,getInput,setInput,getPosition,setPosition,getState,setState
                                      ,(<?>),(<|>),token,choice,between,eof,unexpected,skipMany)
  import Text.ParserCombinators.Parsec.Pos(newPos)
  
  import qualified Text.ProtocolBuffers.Header as P'
  
  default ()
  
  type P st = GenParser Lexed st
  
  parseProto :: String -> ByteString -> Either ParseError D.FileDescriptorProto
  parseProto filename fileContents = do
    let initial_line_number = case lexed of
                                [] -> setPosition (newPos filename 0 0)
                                (l:_) -> setPosition (newPos filename (getLinePos l) 0)
        initState = defaultValue {D.FileDescriptorProto.name=Just (uFromString filename)}
        lexed = alexScanTokens fileContents
    runParser (initial_line_number >> parser) initState filename lexed
  
  
  {-# INLINE mayRead #-}
  mayRead :: ReadS a -> String -> Maybe a
  mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing
  
  true,false :: ByteString
  true = U.fromString "true"
  false = U.fromString "false"
  
  -- Use 'token' via 'tok' to make all the parsers for the Lexed values
  tok :: (Lexed -> Maybe a) -> P s a
  tok f = token show (\lexed -> newPos "" (getLinePos lexed) 0) f
  
  pChar :: Char -> P s ()
  pChar c = tok (\l-> case l of L _ x -> if (x==c) then return () else Nothing
                                _ -> Nothing) <?> ("character "++show c)
  
  eol,eols :: P s ()
  eol = pChar ';'
  eols = skipMany eol
  
  pName :: ByteString -> P s Utf8
  pName name = tok (\l-> case l of L_Name _ x -> if (x==name) then return (Utf8 x) else Nothing
                                   _ -> Nothing) <?> ("name "++show (U.toString name))
  
  rawStrMany :: P s (ByteString,ByteString) -- used for any and all access to L_String
  rawStrMany = fmap mconcat (many1 singleStringLit)
    where singleStringLit :: P s (ByteString,ByteString)
          singleStringLit = tok (\l-> case l of L_String _ raw x -> return (raw,x)
                                                _ -> Nothing) <?> "expected string literal in single or double quotes"
  
  -- In Google's version 2.4.0 there can be default message values which are curly-brace delimited
  -- aggregates.  The lexer eats these fine, and this parser routine should recognized a balanced
  -- expression.  Used with 'undoLexer'.
  --
  -- This assumes the initial (L _ '{' ) has already been parsed.
  getAggregate :: P s [Lexed]
  getAggregate = do
    input <- getInput
    let count :: Int -> Int -> P s [Lexed]
        count !n !depth = do
          -- Not using getNextToken so that the value of 'n' in count is correct.
          t <- anyToken
          case t  of
            L _ '{' -> count (succ n) (succ depth)
            L _ '}' -> let n' = succ n
                           depth' = pred depth
                       in if 0==depth' then return (take n' input)
                            else count n' depth'
            _ -> count (succ n) depth
    ls <- count 0 1
    return ls
  
  getNextToken :: P s Lexed -- used in storing value for UninterpretedOption
  getNextToken = do
    l <- lookAhead anyToken
    case l of
      L_String line _ _ -> rawStrMany >>= \(raw,bs) -> return (L_String line raw bs)
      _ -> anyToken
  
  bsLit :: P s ByteString
  bsLit = fmap fst rawStrMany <?> "quoted bytes literal, raw form"
  
  strLit :: P s Utf8
  strLit = fmap snd rawStrMany >>= \ x -> case isValidUTF8 x of
                                            Nothing -> return (Utf8 x)
                                            Just n -> fail $ "bad utf-8 byte in string literal position # "++show n
  
  intLit,fieldInt,enumInt :: (Num a) => P s a
  intLit = tok (\l-> case l of L_Integer _ x -> return (fromInteger x)
                               _ -> Nothing) <?> "integer literal"
  
  fieldInt = tok (\l-> case l of L_Integer _ x | inRange validRange x && not (inRange reservedRange x) -> return (fromInteger x)
                                 _ -> Nothing) <?> "field number (from 0 to 2^29-1 and not in 19000 to 19999)"
    where validRange = (0,(2^(29::Int))-1)
          reservedRange = (19000,19999)
  
  enumInt = tok (\l-> case l of L_Integer _ x | inRange validRange x -> return (fromInteger x)
                                _ -> Nothing) <?> "enum value (from -2^31 to 2^31-1)"
    where validRange = (toInteger (minBound :: Int32), toInteger (maxBound :: Int32))
  
  doubleLit :: P s Double
  doubleLit = tok (\l-> case l of L_Double _ x -> return x
                                  L_Integer _ x -> return (fromInteger x)
                                  L_Name _ s | s == U.fromString "inf" -> return (1/0)
                                             | s == U.fromString "-inf" -> return (-1/0)
                                             | s == U.fromString "nan" -> return (0/0)
                                  _ -> Nothing) <?> "double (or integer) literal or nan, inf, -inf"
  
  floatLit :: P s Float
  floatLit = tok (\l-> case l of L_Double _ x -> return . fromRational . toRational $ x
                                 L_Integer _ x -> return (fromInteger x)
                                 L_Name _ s | s == U.fromString "inf" -> return (1/0)
                                            | s == U.fromString "-inf" -> return (-1/0)
                                            | s == U.fromString "nan" -> return (0/0)
                                 _ -> Nothing) <?> "float (or integer) literal or nan, inf, -inf"
  
  ident,ident1,ident_package :: P s Utf8
  ident = tok (\l-> case l of L_Name _ x -> return (Utf8 x)
                              _ -> Nothing) <?> "identifier (perhaps dotted)"
  
  ident1 = tok (\l-> case l of L_Name _ x | LC.notElem '.' x -> return (Utf8 x)
                               _ -> Nothing) <?> "identifier (not dotted)"
  
  ident_package = tok (\l-> case l of L_Name _ x | LC.head x /= '.' -> return (Utf8 x)
                                      _ -> Nothing) <?> "package name (no leading dot)"
  
  boolLit :: P s Bool
  boolLit = tok (\l-> case l of L_Name _ x | x == true -> return True
                                           | x == false -> return False
                                _ -> Nothing) <?> "boolean literal ('true' or 'false')"
  
  enumLit :: forall s a. (Read a,ReflectEnum a) => P s a -- This is very polymorphic, and with a good error message
  enumLit = do
    s <- fmap' uToString ident1
    case mayRead reads s of
      Just x -> return x
      Nothing -> let self = enumName (reflectEnumInfo (undefined :: a))
                 in unexpected $ "Enum value not recognized: "++show s++", wanted enum value of type "++show self
  
  -- -------------------------------------------------------------------
  -- subParser changes the user state. It is a bit of a hack and is used
  -- to define an interesting style of parsing.
  subParser :: forall t sSub a s. Show t => GenParser t sSub a -> sSub -> GenParser t s sSub
  subParser doSub inSub = do
    in1 <- getInput
    pos1 <- getPosition
    let out = runParser (setPosition pos1 >> doSub >> getStatus) inSub (sourceName pos1) in1
    case out of
      Left pe -> do
        let anyTok :: Int -> GenParser t s [t]
            anyTok i | i<=0 = return []
                     | otherwise = try (liftM2 (:) anyToken (anyTok (pred i))) <|> (return [])
        context <- anyTok 10
        fail ( unlines [ "The error message from the nested subParser was:\n"++indent (show pe)
                       , "  The next 10 tokens were "++show context ] )
      Right (outSub,in2,pos2) -> setInput in2 >> setPosition pos2 >> return outSub
   where getStatus = liftM3 (,,) getState getInput getPosition
         indent = unlines . map (\s -> ' ':' ':s) . lines
  
  {-# INLINE return' #-}
  return' :: (Monad m) => a -> m a
  return' a = return $! a
  
  {-# INLINE fmap' #-}
  fmap' :: (Monad m) => (a->b) -> m a -> m b
  fmap' f m = m >>= \a -> seq a (return $! (f a))
  
  {-# INLINE update' #-}
  update' :: (s -> s) -> P s ()
  update' f = getState >>= \s -> setState $! (f s)
  
  parser :: P D.FileDescriptorProto D.FileDescriptorProto
  parser = proto >> getState
    where proto = eof <|> (choice [ eol
                                  , importFile
                                  , package
                                  , fileOption
                                  , message upTopMsg
                                  , enum upTopEnum
                                  , extend upTopMsg upTopExt
                                  , service
                                  , syntax
                                  ] >> proto)
          upTopMsg msg = update' (\s -> s {D.FileDescriptorProto.message_type=D.FileDescriptorProto.message_type s |> msg})
          upTopEnum e  = update' (\s -> s {D.FileDescriptorProto.enum_type=D.FileDescriptorProto.enum_type s |> e})
          upTopExt f   = update' (\s -> s {D.FileDescriptorProto.extension=D.FileDescriptorProto.extension s |> f})
  
  importFile,package,fileOption,service :: P D.FileDescriptorProto.FileDescriptorProto ()
  importFile = pName (U.fromString "import") >> strLit >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.dependency=(D.FileDescriptorProto.dependency s) |> p})
  
  package = pName (U.fromString "package") >> do
    p <- ident_package
    eol
    update' (\s -> s {D.FileDescriptorProto.package=Just p})
  
  -- This parses the new extensible option name format of Google's protobuf verison 2.0.2
  -- "foo.(bar.baz).qux" goes to Left [("foo",False),("bar.baz",True),("qux",False)]
  pOptionE :: P s (Either D.UninterpretedOption String)
  pOptionE = do
    let pieces = withParens <|> withoutParens
        withParens = do
          part <- between (pChar '(') (pChar ')') ident
          fmap ((part,True) :) ( choice [ pChar '=' >> return []
                                        , pChar '.' >> withParens
                                        , withoutParens ] )
        withoutParens = do
          parts <- fmap split ident
          let prepend rest = foldr (\part xs -> (part,False):xs) rest parts
          fmap prepend ( choice [ pChar '=' >> return []
                                , pChar '.' >> withParens ] )
    nameParts <- pieces
    case nameParts of
      [(optName,False)] -> return (Right (uToString optName))
      _ -> do uno <- pUnValue (makeUninterpetedOption nameParts)
              return (Left uno)
  
  pOptionWith :: P s t -> P s (Either D.UninterpretedOption String, t)
  pOptionWith = liftM2 (,) (pName (U.fromString "option") >> pOptionE)
  
  -- This does not handle D.UninterpretedOption.aggregate_value yet
  pUnValue :: D.UninterpretedOption -> P s D.UninterpretedOption
  pUnValue uno = getNextToken >>= storeLexed where
    storeLexed (L_Name _ bs) = return $ uno {D.UninterpretedOption.identifier_value = Just (Utf8 bs)}
    storeLexed (L_Integer _ i) | i >= 0 =
      return $ uno { D.UninterpretedOption.positive_int_value = Just (fromInteger i) }
                               | otherwise =
      return $ uno { D.UninterpretedOption.negative_int_value = Just (fromInteger i) }
    storeLexed (L_Double _ d) = return $ uno {D.UninterpretedOption.double_value = Just d }
    storeLexed (L_String _ _raw bs) = return $ uno {D.UninterpretedOption.string_value = Just bs }
    storeLexed l@(L _ '{') = do ls <- getAggregate
                                let bs = uFromString . concatMap undoLexer $ l:ls
                                return $ uno {D.UninterpretedOption.aggregate_value = Just bs }
    storeLexed _ = fail $ "Could not the parse value of an custom (uninterpreted) option"
  
  makeUninterpetedOption :: [(Utf8,Bool)] -> D.UninterpretedOption
  makeUninterpetedOption nameParts = defaultValue { D.UninterpretedOption.name = Seq.fromList . map makeNamePart $ nameParts }
    where makeNamePart (name_part,is_extension) = defaultValue { D.NamePart.name_part = name_part
                                                               , D.NamePart.is_extension =  is_extension }
  
  fileOption = pOptionWith getOld >>= setOption >>= setNew >> eol where
    getOld = fmap (fromMaybe defaultValue . D.FileDescriptorProto.options) getState
    setNew p = update' (\s -> s {D.FileDescriptorProto.options=Just p})
    setOption (Left uno,old) =
      return' (old {D.FileOptions.uninterpreted_option = D.FileOptions.uninterpreted_option old |> uno})
    setOption (Right optName,old) =
      case optName of
        "java_package"          -> strLit  >>= \p -> return' (old {D.FileOptions.java_package        =Just p})
        "java_outer_classname"  -> strLit  >>= \p -> return' (old {D.FileOptions.java_outer_classname=Just p})
        "java_multiple_files"   -> boolLit >>= \p -> return' (old {D.FileOptions.java_multiple_files =Just p})
        "java_generate_equals_and_hash" -> boolLit >>= \p -> return' (old {D.FileOptions.java_generate_equals_and_hash =Just p})
        "java_string_check_utf8"-> boolLit >>= \p -> return' (old {D.FileOptions.java_string_check_utf8 = Just p})
        "optimize_for"          -> enumLit >>= \p -> return' (old {D.FileOptions.optimize_for        =Just p})
        "go_package"            -> strLit  >>= \p -> return' (old {D.FileOptions.go_package          =Just p})
        "cc_generic_services"   -> boolLit >>= \p -> return' (old {D.FileOptions.cc_generic_services =Just p})
        "java_generic_services" -> boolLit >>= \p -> return' (old {D.FileOptions.java_generic_services =Just p})
        "py_generic_services"   -> boolLit >>= \p -> return' (old {D.FileOptions.py_generic_services =Just p})
        "deprecated"            -> boolLit >>= \p -> return' (old {D.FileOptions.deprecated          =Just p})
        "cc_enable_arenas"      -> boolLit >>= \p -> return' (old {D.FileOptions.cc_enable_arenas      =Just p})
        "objc_class_prefix"     -> strLit  >>= \p -> return' (old {D.FileOptions.objc_class_prefix   =Just p})
        "csharp_namespace"      -> strLit  >>= \p -> return' (old {D.FileOptions.csharp_namespace    =Just p})
        "javanano_use_deprecated_package" -> boolLit >>= \p -> return' (old {D.FileOptions.javanano_use_deprecated_package =Just p})
        _ -> unexpected $ "FileOptions has no option named " ++ optName
  
  oneof :: (D.OneofDescriptorProto -> Seq D.FieldDescriptorProto -> P s ()) -> P s ()
  oneof up = pName (U.fromString "oneof") >> do
    self <- ident1
    (o,fs) <- subParser (pChar '{' >> subOneof) (defaultValue {D.OneofDescriptorProto.name=Just self}, Seq.empty)
    up o fs
  
  subOneof :: P (D.OneofDescriptorProto,Seq D.FieldDescriptorProto) ()
  subOneof = pChar '}' <|> (choice [ eof
                                   , fieldOneof >>= upMsgField] >> subOneof)
    where upMsgField f = update' (\(o,fs) -> (o,fs |> f))                    
  
  
  fieldOneof :: P s D.FieldDescriptorProto
  fieldOneof = do
    sType <- ident
    -- parseType may return Nothing, this is fixed up in Text.ProtocolBuffers.ProtoCompile.Resolve.fqField
    let (maybeTypeCode,maybeTypeName) = case parseType (uToString sType) of
                                          Just t -> (Just t,Nothing)
                                          Nothing -> (Nothing, Just sType)
    name <- ident1
    number <- pChar '=' >> fieldInt
    let v1 = defaultValue { D.FieldDescriptorProto.name = Just name
                          , D.FieldDescriptorProto.number = Just number
                          , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL
                          , D.FieldDescriptorProto.type' = maybeTypeCode
                          , D.FieldDescriptorProto.type_name = maybeTypeName
                          }
    eol >> return v1
  
  message :: (D.DescriptorProto -> P s ()) -> P s ()
  message up = pName (U.fromString "message") >> do
    self <- ident1
    up =<< subParser (pChar '{' >> subMessage) (defaultValue {D.DescriptorProto.name=Just self})
  
  -- subMessage is also used to parse group declarations
  subMessage,messageOption,extensions :: P D.DescriptorProto.DescriptorProto ()
  subMessage = (pChar '}') <|> (choice [ eol
                                       , field upNestedMsg Nothing >>= upMsgField
                                       , message upNestedMsg
                                       , enum upNestedEnum
                                       , mapField
                                       , oneof upMsgOneof
                                       , extensions
                                       , extend upNestedMsg upExtField
                                       , messageOption] >> subMessage
                                       )
    where upNestedMsg msg = update' (\s -> s {D.DescriptorProto.nested_type=D.DescriptorProto.nested_type s |> msg})
          upNestedEnum e  = update' (\s -> s {D.DescriptorProto.enum_type=D.DescriptorProto.enum_type s |> e})
          upMsgField f    = update' (\s -> s {D.DescriptorProto.field=D.DescriptorProto.field s |> f})
          upMsgOneof o xs  = update' $ \s ->
            let n = Seq.length (D.DescriptorProto.oneof_decl s)
                xs' = fmap (\s -> s { D.FieldDescriptorProto.oneof_index = Just (fromIntegral n) }) xs
            in s {D.DescriptorProto.oneof_decl=D.DescriptorProto.oneof_decl s |> o
                 ,D.DescriptorProto.field=D.DescriptorProto.field s >< xs'
                 }
             
          upExtField f    = update' (\s -> s {D.DescriptorProto.extension=D.DescriptorProto.extension s |> f})
  
  messageOption = pOptionWith getOld >>= setOption >>= setNew >> eol where
    getOld = fmap (fromMaybe defaultValue . D.DescriptorProto.options) getState
    setNew p = update' (\s -> s {D.DescriptorProto.options=Just p})
    setOption (Left uno,old) =
      return' (old {D.MessageOptions.uninterpreted_option = D.MessageOptions.uninterpreted_option old |> uno })
    setOption (Right optName,old) =
      case optName of
        "message_set_wire_format" -> boolLit >>= \p -> return' (old {D.MessageOptions.message_set_wire_format=Just p})
        "no_standard_descriptor_accessor" -> boolLit >>= \p -> return' (old {D.MessageOptions.no_standard_descriptor_accessor=Just p})
        _ -> unexpected $ "MessageOptions has no option named "++optName
  
  extend :: (D.DescriptorProto -> P s ()) -> (D.FieldDescriptorProto -> P s ()) -> P s ()
  extend upGroup upField = pName (U.fromString "extend") >> do
    typeExtendee <- ident
    pChar '{'
    let rest = (field upGroup (Just typeExtendee) >>= upField) >> eols >> (pChar '}' <|> rest)
    eols >> rest
  
  field :: (D.DescriptorProto -> P s ()) -> Maybe Utf8 -> P s D.FieldDescriptorProto
  field upGroup maybeExtendee = do
    let allowedLabels = case maybeExtendee of
                          Nothing -> ["optional","repeated","required"]
                          Just {} -> ["optional","repeated"] -- cannot declare a required extension and an oneof extension. 
    sLabel <- choice . map (pName . U.fromString) $ allowedLabels
    theLabel <- maybe (fail ("not a valid Label :"++show sLabel)) return (parseLabel (uToString sLabel))
    sType <- ident
    -- parseType may return Nothing, this is fixed up in Text.ProtocolBuffers.ProtoCompile.Resolve.fqField
    let (maybeTypeCode,maybeTypeName) = case parseType (uToString sType) of
                                          Just t -> (Just t,Nothing)
                                          Nothing -> (Nothing, Just sType)
    name <- ident1
    number <- pChar '=' >> fieldInt
    let v1 = defaultValue { D.FieldDescriptorProto.name = Just name
                          , D.FieldDescriptorProto.number = Just number
                          , D.FieldDescriptorProto.label = Just theLabel
                          , D.FieldDescriptorProto.type' = maybeTypeCode
                          , D.FieldDescriptorProto.type_name = maybeTypeName
                          , D.FieldDescriptorProto.extendee = maybeExtendee }
    if maybeTypeCode == Just TYPE_GROUP
      then do let nameString = uToString name
              when (null nameString) (fail "Impossible? ident1 for field name was empty")
              when (not (isUpper (head nameString))) (fail $ "Group names must start with an upper case letter: "++show name)
              upGroup =<< subParser (pChar '{' >> subMessage) (defaultValue {D.DescriptorProto.name=Just name})
              let fieldName = Just $ uFromString (map toLower nameString)  -- down-case the whole name
                  v = v1 { D.FieldDescriptorProto.name = fieldName
                         , D.FieldDescriptorProto.type_name = Just name }
              return v
      else (eol >> return v1) <|> (subParser (pChar '[' >> subField theLabel maybeTypeCode) v1)
  
  subField,defaultConstant :: Label -> Maybe Type -> P D.FieldDescriptorProto ()
  subField label mt = do
    (defaultConstant label mt <|> fieldOption label mt) <?> "expected \"default\" or a fieldOption"
    (pChar ']' >> eol) <|> (pChar ',' >> subField label mt)
  
  defaultConstant LABEL_REPEATED _ = pName (U.fromString "default") >> fail "Repeated fields cannot have a default value"
  defaultConstant _ mt = do
    _ <- pName (U.fromString "default")
    maybeDefault <- pChar '=' >> fmap Just (constant mt)
    -- XXX Hack: we lie about Utf8 for the default_value below
    update' (\s -> s { D.FieldDescriptorProto.default_value = fmap Utf8 maybeDefault })
  
  -- This does a type and range safe parsing of the default value,
  -- except for enum constants which cannot be checked (the definition
  -- may not have been parsed yet).
  --
  -- Double and Float are checked to be not-Nan and not-Inf.  The
  -- int-like types are checked to be within the corresponding range.
  constant :: Maybe Type -> P s ByteString
  -- With Nothing the next item may be an enum constant or a '{' and an aggregate.
  constant Nothing = enumIdent <?> "expected the name of an enum or a curly-brace-enclosed aggregate value"
    where enumIdent = fmap utf8 ident1 -- hopefully a matching enum; forget about Utf8
  constant (Just t) =
    case t of
      TYPE_DOUBLE  -> do d <- doubleLit
  --                       when (isNaN d || isInfinite d)
  --                            (fail $ "default floating point literal "++show d++" is out of range for type "++show t)
                         return' (utf8 . uFromString . showRF $ d)
      TYPE_FLOAT   -> do fl <- floatLit
  {-
                         let fl :: Float
                             fl = read (show d)
  --                       when (isNaN fl || isInfinite fl || (d==0) /= (fl==0))
  --                            (fail $ "default floating point literal "++show d++" is out of range for type "++show t)
                         when (isNaN fl /= isNaN d || isInfinite fl /= isInfinite d  || (d==0) /= (fl==0))
                              (fail $ "default floating point literal "++show d++" is out of range for type "++show t)
  -}
                         return' (utf8 . uFromString . showRF $ fl)
      TYPE_BOOL    -> boolLit >>= \b -> return' $ if b then true else false
      TYPE_STRING  -> strLit >>= return . utf8
      TYPE_BYTES   -> bsLit
      TYPE_GROUP   -> unexpected $ "cannot have a default for field of "++show t
      TYPE_MESSAGE -> unexpected $ "cannot have a default for field of "++show t
      TYPE_ENUM    -> fmap utf8 ident1 -- IMPOSSIBLE : SHOULD HAVE HAD Maybe Type PARAMETER match Nothing
      TYPE_SFIXED32 -> f (undefined :: Int32)
      TYPE_SINT32   -> f (undefined :: Int32)
      TYPE_INT32    -> f (undefined :: Int32)
      TYPE_SFIXED64 -> f (undefined :: Int64)
      TYPE_SINT64   -> f (undefined :: Int64)
      TYPE_INT64    -> f (undefined :: Int64)
      TYPE_FIXED32  -> f (undefined :: Word32)
      TYPE_UINT32   -> f (undefined :: Word32)
      TYPE_FIXED64  -> f (undefined :: Word64)
      TYPE_UINT64   -> f (undefined :: Word64)
    where f :: (Bounded a,Integral a) => a -> P s ByteString
          f u = do let range = (toInteger (minBound `asTypeOf` u),toInteger (maxBound `asTypeOf` u))
                   i <- intLit
                   when (not (inRange range i))
                        (fail $ "default integer value "++show i++" is out of range for type "++show t)
                   return' (utf8 . uFromString . show $ i)
  
  fieldOption :: Label -> Maybe Type -> P D.FieldDescriptorProto ()
  fieldOption label mt = liftM2 (,) pOptionE getOld >>= setOption >>= setNew where
    getOld = fmap (fromMaybe defaultValue . D.FieldDescriptorProto.options) getState
    setNew p = update' (\s -> s { D.FieldDescriptorProto.options = Just p })
    setOption (Left uno,old) =
      return' (old {D.FieldOptions.uninterpreted_option = D.FieldOptions.uninterpreted_option old |> uno })
    setOption (Right optName,old) =
      case optName of
        "ctype" | (Just TYPE_STRING) == mt -> do
          enumLit >>= \p -> return' (old {D.FieldOptions.ctype=Just p})
                | otherwise -> unexpected $ "field option cyte is only defined for string fields"
        -- "experimental_map_key" | Nothing == mt -> do
         -- strLit >>= \p -> return' (old {D.FieldOptions.experimental_map_key=Just p})
         --                      | otherwise -> unexpected $ "field option experimental_map_key is only defined for messages"
        "packed" | isValidPacked label mt -> do
          boolLit >>= \p -> return' (old {D.FieldOptions.packed=Just p})
                 | otherwise -> unexpected $ "field option packed is not defined for this kind of field"
        "deprecated" -> boolLit >>= \p -> return' (old {D.FieldOptions.deprecated=Just p})
        _ -> unexpected $ "FieldOptions has no option named "++optName
  
  isValidPacked :: Label -> Maybe Type -> Bool
  isValidPacked LABEL_REPEATED Nothing = True -- provisional, okay if Enum but wrong if Message, checked in Resolve.fqField
  isValidPacked LABEL_REPEATED (Just typeCode) =
    case typeCode of
      TYPE_STRING -> False
      TYPE_GROUP -> False
      TYPE_BYTES -> False
      TYPE_MESSAGE -> False -- Impossible value for typeCode from parseType, but here for completeness
      TYPE_ENUM -> True     -- Impossible value for typeCode from parseType, but here for completeness
      _ -> True
  isValidPacked _ _ = False
  
  -- mapField = "map" "<" keyType "," type ">" mapName "=" fieldNumber [ "[" fieldOptions "]" ] ";"
  -- keyType = "int32" | "int64" | "uint32" | "uint64" | "sint32" | "sint64" |
  --           "fixed32" | "fixed64" | "sfixed32" | "sfixed64" | "bool" | "string"
  --
  -- Protobuf:
  -- map<key_type, value_type> map_field = N;
  --
  -- Equivalent to:
  -- message value_type {}
  --
  -- message MapFieldEntry {
  --   key_type key = 1;
  --   value_type value = 2;
  -- }
  --
  -- repeated MapFieldEntry map_field = N;
  --
  -- In Haskell:
  -- module ValueType
  -- module Map_field_Entry where Map_field_Entry { key :: KeyType, value :: ValueType }
  -- Map_field.Entry where Entry { key :: KeyType, value :: ValueType }
  
  mapField :: P D.DescriptorProto.DescriptorProto ()
  mapField = do
      pName (U.fromString "map")
      pChar '<'
      keyType   <- ident1
      pChar ','
      valueType <- ident
      pChar '>'
      self      <- ident1
      number    <- pChar '=' >> enumInt
  
      let typeTypeName t1 =
              case parseType (uToString t1) of
                Just t2 -> (Just t2, Nothing)
                Nothing -> (Nothing, Just t1)
      -- key
      let key =
              let (maybeTypeCode, maybeTypeName)   = typeTypeName keyType in
              defaultValue {
                  D.FieldDescriptorProto.name      = Just $ P'.Utf8 $ U.fromString "key",
                  D.FieldDescriptorProto.number    = Just 1,
                  D.FieldDescriptorProto.label     = Just LABEL_REQUIRED,
                  D.FieldDescriptorProto.type'     = maybeTypeCode,
                  D.FieldDescriptorProto.type_name = maybeTypeName
              }
      -- value
      let value =
              let (maybeTypeCode, maybeTypeName)   = typeTypeName valueType in
              defaultValue {
                  D.FieldDescriptorProto.name      = Just $ P'.Utf8 $ U.fromString "value",
                  D.FieldDescriptorProto.number    = Just 2,
                  D.FieldDescriptorProto.label     = Just LABEL_REQUIRED,
                  D.FieldDescriptorProto.type'     = maybeTypeCode,
                  D.FieldDescriptorProto.type_name = maybeTypeName
              }
      -- Map_field_Entry: (key,value) pair
      let entryName = self <> (P'.Utf8 (U.fromString "_Entry"))
      let mapFieldEntry = defaultValue {
            D.DescriptorProto.name    = Just entryName,
            D.DescriptorProto.field   = Seq.fromList [key, value],
            D.DescriptorProto.options =
                  Just $ defaultValue {
                      D.MessageOptions.map_entry = Just True
                  }
          }
      let field = defaultValue {
            D.FieldDescriptorProto.name      = Just self,
            D.FieldDescriptorProto.number    = Just number,
            D.FieldDescriptorProto.label     = Just LABEL_REPEATED,
            D.FieldDescriptorProto.type_name = Just entryName
          }
      update' $ \s -> s
          { D.DescriptorProto.nested_type = D.DescriptorProto.nested_type s |> mapFieldEntry
          , D.DescriptorProto.field       = D.DescriptorProto.field s       |> field
          }
  
  enum :: (D.EnumDescriptorProto -> P s ()) -> P s ()
  enum up = pName (U.fromString "enum") >> do
    self <- ident1
    up =<< subParser (pChar '{' >> subEnum) (defaultValue {D.EnumDescriptorProto.name=Just self})
  
  subEnum,enumOption :: P D.EnumDescriptorProto.EnumDescriptorProto ()
  subEnum = eols >> rest -- Note: Must check enumOption before enumVal
    where rest = (enumOption <|> enumVal) >> eols >> (pChar '}' <|> rest)
  
  enumOption = pOptionWith getOld >>= setOption >>= setNew >> eol where
    getOld = fmap (fromMaybe defaultValue . D.EnumDescriptorProto.options) getState
    setNew p = update' (\s -> s {D.EnumDescriptorProto.options=Just p})
    setOption (Left uno,old) =
      return' $  (old {D.EnumOptions.uninterpreted_option = D.EnumOptions.uninterpreted_option old |> uno })
    setOption (Right optName,_old) =
      case optName of
        _ -> unexpected $ "EnumOptions has no option named "++optName
  
  enumVal :: P D.EnumDescriptorProto ()
  enumVal = do
    name <- ident1
    number <- pChar '=' >> enumInt
    let v1 = defaultValue { D.EnumValueDescriptorProto.name = Just name
                          , D.EnumValueDescriptorProto.number = Just number }
    v <- (eol >> return v1) <|> subParser (pChar '[' >> subEnumValue) v1
    update' (\s -> s {D.EnumDescriptorProto.value=D.EnumDescriptorProto.value s |> v})
  
  subEnumValue,enumValueOption :: P D.EnumValueDescriptorProto ()
  subEnumValue = enumValueOption >> ( (pChar ']' >> eol) <|> (pChar ',' >> subEnumValue) )
  
  enumValueOption = liftM2 (,) pOptionE getOld >>= setOption >>= setNew where
    getOld = fmap (fromMaybe defaultValue . D.EnumValueDescriptorProto.options) getState
    setNew p = update' (\s -> s {D.EnumValueDescriptorProto.options=Just p})
    setOption (Left uno,old) =
      return' $  (old {D.EnumValueOptions.uninterpreted_option = D.EnumValueOptions.uninterpreted_option old |> uno })
    setOption (Right optName,_old) =
      case optName of
        _ -> unexpected $ "EnumValueOptions has no option named "++optName
  
  extensions = pName (U.fromString "extensions") >> do
    start <- fieldInt
    let noEnd = eol >> return (succ start)
        toEnd = pName (U.fromString "to") >> (fieldInt <|> (pName (U.fromString "max") >> return (getFieldId maxBound)))
    end <- choice [ noEnd, toEnd ]
    let e = defaultValue { D.ExtensionRange.start = Just start
                         , D.ExtensionRange.end = Just (succ end) }  -- One _past_ the end!
    update' (\s -> s {D.DescriptorProto.extension_range=D.DescriptorProto.extension_range s |> e})
  
  service = pName (U.fromString "service") >> do
    name <- ident1
    f <- subParser (pChar '{' >> subService) (defaultValue {D.ServiceDescriptorProto.name=Just name})
    update' (\s -> s {D.FileDescriptorProto.service=D.FileDescriptorProto.service s |> f})
  
   where subService = pChar '}' <|> (choice [ eol, rpc, serviceOption ] >> subService)
  
  syntax = pName (U.fromString "syntax") >> do
    pChar '=' 
    p <- strLit
    update' (\s -> s {D.FileDescriptorProto.syntax=Just p})
  
  serviceOption,rpc :: P D.ServiceDescriptorProto ()
  serviceOption = pOptionWith getOld >>= setOption >>= setNew >> eol where
    getOld = fmap (fromMaybe defaultValue . D.ServiceDescriptorProto.options) getState
    setNew p = update' (\s -> s {D.ServiceDescriptorProto.options=Just p})
    setOption (Left uno,old) =
      return' (old {D.ServiceOptions.uninterpreted_option = D.ServiceOptions.uninterpreted_option old |> uno })
    setOption (Right optName,_old) =
      case optName of
        _ -> unexpected $ "ServiceOptions has no option named "++optName
  
  rpc = pName (U.fromString "rpc") >> do
    name <- ident1
    let withStreaming =
          (pName (U.fromString "stream") >> (,True) <$> ident) <|> (,False) <$> ident
    (input, inputStream) <- between (pChar '(') (pChar ')') withStreaming
    _ <- pName (U.fromString "returns")
    (output, outputStream) <- between (pChar '(') (pChar ')') withStreaming
    let m1 = defaultValue { D.MethodDescriptorProto.name=Just name
                          , D.MethodDescriptorProto.input_type=Just input
                          , D.MethodDescriptorProto.client_streaming=Just inputStream
                          , D.MethodDescriptorProto.output_type=Just output
                          , D.MethodDescriptorProto.server_streaming=Just outputStream
                          }
    m <- (eol >> return m1) <|> subParser (pChar '{' >> subRpc) m1
    update' (\s -> s {D.ServiceDescriptorProto.method=D.ServiceDescriptorProto.method s |> m})
  
  subRpc,rpcOption :: P D.MethodDescriptorProto ()
  subRpc = pChar '}' <|> (choice [ eol, rpcOption ] >> subRpc)
  
  rpcOption = pOptionWith getOld >>= setOption >>= setNew >> eol where
    getOld = fmap (fromMaybe defaultValue . D.MethodDescriptorProto.options) getState
    setNew p = update' (\s -> s {D.MethodDescriptorProto.options=Just p})
    setOption (Left uno,old) =
      return' $  (old {D.MethodOptions.uninterpreted_option = D.MethodOptions.uninterpreted_option old |> uno })
    setOption (Right optName,_old) =
      case optName of
        _ -> unexpected $ "MethodOptions has no option named "++optName
  
  -- see google's stubs/strutil.cc lines 398-449/1121 and C99 specification
  -- This mainly targets three digit octal codes
  cEncode :: [Word8] -> [Char]
  cEncode = concatMap one where
    one :: Word8 -> [Char]
    -- special non-octal escaped values
    one 9 = sl  't'
    one 10 = sl 'n'
    one 13 = sl 'r'
    one 34 = sl '"'
    one 39 = sl '\''
    one 92 = sl '\\'
    -- main case of unescaped value
    one x | (32 <= x) && (x < 127) = [toEnum .  fromEnum $  x]
    -- below are the octal escaped values.  This always emits 3 digits.
    one 0 = '\\':"000"
    one x | x < 8 = '\\':'0':'0':(showOct x "")
          | x < 64 = '\\':'0':(showOct x "")
          | otherwise = '\\':(showOct x "")
    sl c = ['\\',c]
  
  showRF :: (Show a, RealFloat a) => a -> String
  showRF x | isNaN x = "nan"
           | isInfinite x = if 0 < x then "inf" else "-inf"
           | otherwise = show x
  
  -- Aggregate
  {-
  data Lexed = L_Integer !Int !Integer
             | L_Double !Int !Double
             | L_Name !Int !L.ByteString
             | L_String !Int !L.ByteString !L.ByteString
             | L !Int !Char
             | L_Error !Int !String
             -}
  
  undoLexer :: Lexed -> String
  undoLexer (L_Integer _ integer) = ' ':show integer
  undoLexer (L_Double _ double) = ' ':showRF double
  undoLexer (L_Name _ bs) = ' ':U.toString bs
  undoLexer (L_String _ _ bs) = let middle = L.unpack bs
                                    encoded = cEncode middle  -- escapes both quote and double-quote
                                    s = '\'' : encoded ++ "'"
                                in ' ':s
  undoLexer (L _ '{') = " {\n"
  undoLexer (L _ '}') = " }\n"
  undoLexer (L _ ';') = ";\n"
  undoLexer (L _ char) = ' ':[char]
  undoLexer (L_Error _ errorMessage) = error ("Lexer failure found when parsing aggregate default value\n:"++errorMessage) -- XXX improve error reporting?
  