hprotoc 2.0.2 → 2.0.5
raw patch · 6 files changed
+505/−353 lines, 6 filesdep ~protocol-buffersdep ~protocol-buffers-descriptor
Dependency ranges changed: protocol-buffers, protocol-buffers-descriptor
Files
- README +1/−1
- Text/ProtocolBuffers/ProtoCompile/Lexer.x +1/−1
- Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +6/−6
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +82/−29
- Text/ProtocolBuffers/ProtoCompile/Resolve.hs +412/−313
- hprotoc.cabal +3/−3
README view
@@ -1,5 +1,5 @@ To regenerate the plugin haskell files, please run -hprotoc --prefix=Text -d protoc-gen-haskell -I google-proto-files/ google/protobuf/plugin.proto +hprotoc -u --prefix=Text -d protoc-gen-haskell -I google-proto-files/ google/protobuf/plugin.proto This was last populated from version 2.4.0a of Google's code.
Text/ProtocolBuffers/ProtoCompile/Lexer.x view
@@ -32,7 +32,7 @@ @inStr = @hexEscape | @octEscape | @charEscape | [^'\"\0\n] @strLit = ['] (@inStr | [\"])* ['] | [\"] (@inStr | ['])* [\"] -$special = [=\(\)\,\;\[\]\{\}\.]+$special = [=\(\)\,\;\[\]\{\}\.\:] @ninf = [\-][i][n][f]
Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs view
@@ -39,7 +39,7 @@ import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Reflections-import Text.ProtocolBuffers.WireMessage(size'Varint,toWireTag,toPackedWireTag,runPut,Wire(..))+import Text.ProtocolBuffers.WireMessage(size'WireTag,toWireTag,toPackedWireTag,runPut,Wire(..)) import Text.ProtocolBuffers.ProtoCompile.Resolve(ReMap,NameMap(..)) import qualified Data.Foldable as F(foldr,toList)@@ -70,7 +70,7 @@ -> NameMap -> D.FileDescriptorProto -> ProtoInfo-makeProtoInfo (unknownField,lazyFields) (NameMap (packageName,hPrefix,hParent) reMap)+makeProtoInfo (unknownField,lazyFieldsOpt) (NameMap (packageName,hPrefix,hParent) reMap) fdp@(D.FileDescriptorProto { D.FileDescriptorProto.name = Just rawName }) = ProtoInfo protoName (pnPath protoName) (toString rawName) keyInfos allMessages allEnums allKeys where protoName = case hParent of@@ -92,7 +92,7 @@ (D.DescriptorProto.name x)) groups parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))]- in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFields) msg+ in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt) msg : concatMap (\x -> processMSG parent' (checkGroup x) x) (F.toList (D.DescriptorProto.nested_type msg)) processENM parent msg = foldr ((:) . makeEnumInfo' reMap parent') nested@@ -129,7 +129,7 @@ -> Bool -- msgIsGroup -> (Bool,Bool) -- unknownField and lazyFields -> D.DescriptorProto -> DescriptorInfo-makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFields)+makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt) (D.DescriptorProto.DescriptorProto { D.DescriptorProto.name = Just rawName , D.DescriptorProto.field = rawFields@@ -137,7 +137,7 @@ , D.DescriptorProto.extension_range = extension_range }) = let di = DescriptorInfo protoName (pnPath protoName) msgIsGroup fieldInfos keyInfos extRangeList (getKnownKeys protoName)- unknownField lazyFields+ unknownField lazyFieldsOpt in di -- trace (toString rawName ++ "\n" ++ show di ++ "\n\n") $ di where protoName = toHaskell reMap $ fqAppend parent [IName rawName] fieldInfos = fmap (toFieldInfo' reMap (protobufName protoName)) rawFields@@ -179,7 +179,7 @@ wt2 | validPacked = Just (toWireTag fieldId fieldType -- read unpacked ,toPackedWireTag fieldId) -- read packed | otherwise = Nothing- wtLength = size'Varint (getWireTag wt)+ wtLength = size'WireTag wt packedOption = case mayOpt of Just (D.FieldOptions { D.FieldOptions.packed = Just True }) -> True _ -> False
Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} -- | 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.@@ -54,6 +55,7 @@ -- 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)@@ -62,14 +64,14 @@ import Data.Monoid(mconcat) import Data.Sequence((|>)) import qualified Data.Sequence as Seq(fromList)+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,pzero+ ,getInput,setInput,getPosition,setPosition,getState,setState ,(<?>),(<|>),token,choice,between,eof,unexpected,skipMany) import Text.ParserCombinators.Parsec.Pos(newPos) --- import Debug.Trace(trace)- default () type P = GenParser Lexed@@ -79,14 +81,10 @@ let initial_line_number = case lexed of [] -> setPosition (newPos filename 0 0) (l:_) -> setPosition (newPos filename (getLinePos l) 0)- initState = defaultValue {D.FileDescriptorProto.name=utf8FromString filename}+ initState = defaultValue {D.FileDescriptorProto.name=Just (uFromString filename)} lexed = alexScanTokens fileContents runParser (initial_line_number >> parser) initState filename lexed -utf8FromString :: String -> Maybe Utf8-utf8FromString = Just . Utf8 . U.fromString-utf8ToString :: Utf8 -> String-utf8ToString = U.toString . utf8 {-# INLINE mayRead #-} mayRead :: ReadS a -> String -> Maybe a@@ -118,6 +116,28 @@ 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@@ -179,7 +199,7 @@ 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' utf8ToString ident1+ s <- fmap' uToString ident1 case mayRead reads s of Just x -> return x Nothing -> let self = enumName (reflectEnumInfo (undefined :: a))@@ -199,7 +219,7 @@ 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) + 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@@ -217,7 +237,7 @@ update' :: (s -> s) -> P s () update' f = getState >>= \s -> setState $! (f s) -parser :: P D.FileDescriptorProto D.FileDescriptorProto +parser :: P D.FileDescriptorProto D.FileDescriptorProto parser = proto >> getState where proto = eof <|> (choice [ eol , importFile@@ -256,13 +276,14 @@ , pChar '.' >> withParens ] ) nameParts <- pieces case nameParts of- [(optName,False)] -> return (Right (utf8ToString optName))+ [(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)}@@ -272,7 +293,10 @@ 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 _ = pzero+ 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 }@@ -286,10 +310,14 @@ 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})- "optimize_for" -> enumLit >>= \p -> return' (old {D.FileOptions.optimize_for =Just p})+ "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})+ "optimize_for" -> enumLit >>= \p -> return' (old {D.FileOptions.optimize_for =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}) _ -> unexpected $ "FileOptions has no option named " ++ optName message :: (D.DescriptorProto -> P s ()) -> P s ()@@ -319,6 +347,7 @@ 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 ()@@ -329,15 +358,15 @@ eols >> rest field :: (D.DescriptorProto -> P s ()) -> Maybe Utf8 -> P s D.FieldDescriptorProto-field upGroup maybeExtendee = do +field upGroup maybeExtendee = do let allowedLabels = case maybeExtendee of Nothing -> ["optional","repeated","required"] Just {} -> ["optional","repeated"] -- cannot declare a required extension sLabel <- choice . map (pName . U.fromString) $ allowedLabels- theLabel <- maybe (fail ("not a valid Label :"++show sLabel)) return (parseLabel (utf8ToString sLabel))+ 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 (utf8ToString sType) of+ let (maybeTypeCode,maybeTypeName) = case parseType (uToString sType) of Just t -> (Just t,Nothing) Nothing -> (Nothing, Just sType) name <- ident1@@ -349,11 +378,11 @@ , D.FieldDescriptorProto.type_name = maybeTypeName , D.FieldDescriptorProto.extendee = maybeExtendee } if maybeTypeCode == Just TYPE_GROUP- then do let nameString = utf8ToString name+ 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 = utf8FromString (map toLower nameString) -- down-case the whole 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@@ -361,7 +390,7 @@ subField,defaultConstant :: Label -> Maybe Type -> P D.FieldDescriptorProto () subField label mt = do- defaultConstant label mt <|> fieldOption label mt+ (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"@@ -378,13 +407,15 @@ -- 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-constant Nothing = fmap utf8 ident1 -- hopefully a matching enum; forget about Utf8+-- 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' (U.fromString . showRF $ d)+ return' (utf8 . uFromString . showRF $ d) TYPE_FLOAT -> do fl <- floatLit {- let fl :: Float@@ -394,7 +425,7 @@ 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' (U.fromString . showRF $ fl)+ return' (utf8 . uFromString . showRF $ fl) TYPE_BOOL -> boolLit >>= \b -> return' $ if b then true else false TYPE_STRING -> strLit >>= return . utf8 TYPE_BYTES -> bsLit@@ -416,7 +447,7 @@ i <- intLit when (not (inRange range i)) (fail $ "default integer value "++show i++" is out of range for type "++show t)- return' (U.fromString . show $ i)+ return' (utf8 . uFromString . show $ i) fieldOption :: Label -> Maybe Type -> P D.FieldDescriptorProto () fieldOption label mt = liftM2 (,) pOptionE getOld >>= setOption >>= setNew where@@ -538,7 +569,6 @@ 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]@@ -559,9 +589,32 @@ | x < 64 = '\\':'0':(showOct x "") | otherwise = '\\':(showOct x "") sl c = ['\\',c]--} showRF :: (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?
Text/ProtocolBuffers/ProtoCompile/Resolve.hs view
@@ -1,12 +1,62 @@-{- fixing resolution +{- fixing resolution. This is a large beast of a module. Sorry.+ updated for version 2.0.3 to match protoc's namespace resolution better+ updated for version 2.0.4 to differentiate Entity and E'Entity, this makes eName a total selector+ entityField uses resolveMGE instead of expectMGE and resolveEnv : this should allow field types to resolve just to MGE insteadof other field names. what about keys 'extendee' resolution to Message names only? expectM in entityField - makeTopLevel is the main internal entry point in this module.+ 'makeTopLevel' is the main internal entry point in this module. This is called from loadProto' which has two callers: loadProto and loadCodeGenRequest + makeTopLevel uses a lazy 'myFixSE' trick and so the order of execution is not immediately clear.++ The environment for name resolution comes from the global' declaration which first involves using+ resolveFDP/runRE (E'Entity). To make things more complicated the definition of global' passes+ global' to (resolveFDP fdp).++ The resolveFDP/runRE runs all the fq* stuff (E'Entity and consumeUNO/interpretOption/resolveHere).++ Note that the only source of E'Error values of E'Entity are from 'unique' detecting name+ collisions.++ This global' environment gets fed back in as global'Param to form the SEnv for running the+ entityMsg, entityField, entityEnum, entityService functions. These clean up the parsed descriptor+ proto structures into dependable and fully resolved ones.++ The kids operator and the unZip are used to seprate and collect all the error messages, so that+ they can be checked for and reported as a group.++ ====++ Problem? Nesting namespaces allows shadowing. I forget if Google's protoc allows this.++ Problem? When the current file being resolves has the same package name as an imported file then+ hprotoc will find unqualified names in the local name space and the imported name space. But if+ there is a name collision between the two then hprotoc will not detect this; the unqualified name+ will resolve to the local file and not observe the duplicate from the import. TODO: check what+ Google's protoc does in this case.++ Solution to either of the above might be to resolve to a list of successes and check for a single+ success. This may be too lazy.++ ====++ aggregate option types not handled: Need to take fk and bytestring from parser and:+ 1) look at mVal of fk (E'Message) to understand what fields are expected (listed in mVals of this mVal).+ 2) lex the bytestring+ 3) parse the sequence of "name" ":" "value" by doing+ 4) find "name" in the expected list from (1) (E'Field)+ 5) Look at the fType of this E'Field and parse the "value", if Nothing (message/group/enum) then+ 6) resolve name and look at mVal+ 7) if enum then parse "value" as identifier or if message or group+ 8) recursively go to (1) and either prepend lenght (message) or append stop tag (group)+ 9) runPut to get the wire encoded field tag and value when Just a simple type+ 10) concatentanate the results of (3) to get the wire encoding for the message value++ Handling recursive message/groups makes this more annoying.+ -} -- | This huge module handles the loading and name resolution. The@@ -14,6 +64,9 @@ -- The makeNameMaps command makes the translator from proto name to -- Haskell name. Many possible errors in the proto data are caught -- and reported by these operations.+--+-- hprotoc will actually resolve more unqualified imported names than Google's protoc which requires+-- more qualified names. I do not have the obsessive nature to fix this. module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,loadCodeGenRequest,makeNameMap,makeNameMaps,getTLS ,Env(..),TopLevel(..),ReMap,NameMap(..),LocalFP(..),CanonFP(..)) where @@ -88,8 +141,6 @@ import qualified Data.Set as Set import qualified Data.Traversable as T ---import Debug.Trace(trace)- -- Used by err and throw indent :: String -> String indent = unlines . map (\str -> ' ':' ':str) . lines@@ -171,7 +222,10 @@ -- by 1 or more Global TopLevel namespaces (self and imported files). -- Entities in first Global TopLevel namespace can refer to each other -- and to Entities in the list of directly imported TopLevel namespaces only.-data Env = Local Entity {- E'Message -} Env | Global TopLevel [TopLevel] deriving Show+data Env = Local [IName String] EMap {- E'Message,E'Group,E'Service -} Env+ | Global TopLevel [TopLevel]+ deriving Show+ -- | TopLevel corresponds to all items defined in a .proto file. This -- includes the FileOptions since this will be consulted when -- generating the Haskel module names, and the imported files are only@@ -180,25 +234,41 @@ , top'Package :: [IName String] , top'FDP :: Either ErrStr D.FileDescriptorProto -- resolvedFDP'd , top'mVals :: EMap } deriving Show+ -- | The EMap type is a local namespace attached to an entity-type EMap = Map (IName String) Entity+--+-- The E'Error values come from using unique to resolse name collisions when building EMap+type EMap = Map (IName String) E'Entity+ -- | An Entity is some concrete item in the namespace of a proto file. -- All Entity values have a leading-dot fully-qualified with the package "eName". -- The E'Message,Group,Service have EMap namespaces to inner Entity items. data Entity = E'Message { eName :: [IName String], validExtensions :: [(FieldId,FieldId)] , mVals :: EMap {- E'Message,Group,Field,Key,Enum -} }+ | E'Group { eName :: [IName String], mVals :: EMap {- E'Message,Group,Field,Key,Enum -} }- | E'Field { eName :: [IName String], fNumber :: FieldId, fType :: Maybe D.Type- , mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }++ | E'Service { eName :: [IName String], mVals :: EMap {- E'Method -} }+ | E'Key { eName :: [IName String], eMsg :: Either ErrStr Entity {- E'Message -} , fNumber :: FieldId, fType :: Maybe D.Type , mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }++ | E'Field { eName :: [IName String], fNumber :: FieldId, fType :: Maybe D.Type+ , mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }+ | E'Enum { eName :: [IName String], eVals :: Map (IName Utf8) Int32 }- | E'Service { eName :: [IName String], mVals :: EMap {- E'Method -} }+ | E'Method { eName :: [IName String], eMsgIn,eMsgOut :: Maybe (Either ErrStr Entity) {- E'Message -} }- | E'Error String [Entity] deriving (Show) +-- This type handles entity errors by storing them rather than propagating or throwing them.+--+-- The E'Error values come from using unique to resolse name collisions when building EMap+data E'Entity = E'Ok Entity+ | E'Error String [E'Entity]+ deriving (Show)+ newtype LocalFP = LocalFP { unLocalFP :: FilePath } deriving (Read,Show,Eq,Ord) newtype CanonFP = CanonFP { unCanonFP :: FilePath } deriving (Read,Show,Eq,Ord) @@ -210,17 +280,21 @@ fpCanonToLocal | Canon.pathSeparator == Local.pathSeparator = LocalFP . unCanonFP | otherwise = LocalFP . Local.joinPath . Canon.splitDirectories . unCanonFP -allowed :: Env -> [([IName String],[IName String])]-allowed (Local entity env) = allowedE entity : allowed env-allowed (Global t ts) = map allowedT (t:ts)-allowedE :: Entity -> ([IName String], [IName String])-allowedE entity = ((,) (eName entity)) $- case get'mVals entity of- Nothing -> []- Just m -> M.keys m+-- Used to create optimal error messages+allowedGlobal :: Env -> [([IName String],[IName String])]+allowedGlobal (Local _ _ env) = allowedGlobal env+allowedGlobal (Global t ts) = map allowedT (t:ts)+ allowedT :: TopLevel -> ([IName String], [IName String]) allowedT tl = (top'Package tl,M.keys (top'mVals tl)) +-- Used to create optional error messages+allowedLocal :: Env -> [([IName String],[IName String])]+allowedLocal (Global _t _ts) = []+allowedLocal (Local name vals env) = allowedE : allowedLocal env+ where allowedE :: ([IName String], [IName String])+ allowedE = (name,M.keys vals)+ data NameMap = NameMap (FIName Utf8,[MName String],[MName String]) ReMap -- Create a mapping from the "official" name to the Haskell hierarchy mangled name@@ -232,6 +306,13 @@ , my'Env :: Env } -- , my'Template :: ProtoName } +-- E'Service here is arbitrary+emptyEntity :: Entity+emptyEntity = E'Service [IName "emptyEntity from myFix"] mempty++emptyEnv :: Env+emptyEnv = Global (TopLevel "emptyEnv from myFix" [IName "emptyEnv form myFix"] (Left "emptyEnv: top'FDP does not exist") mempty) []+ instance Show SEnv where show (SEnv p e) = "(SEnv "++show p++" ; "++ whereEnv e ++ ")" --" ; "++show (haskellPrefix t,parentModule t)++ " )" @@ -239,6 +320,9 @@ type SE a = ReaderT SEnv (Either ErrStr) a +runSE :: SEnv -> SE a -> Either ErrStr a+runSE sEnv m = runReaderT m sEnv+ fqName :: Entity -> FIName Utf8 fqName = fiFromString . joinDot . eName @@ -249,6 +333,10 @@ iToString = IName . toString . iName -- Three entities provide child namespaces: E'Message, E'Group, and E'Service+get'mVals'E :: E'Entity -> Maybe EMap+get'mVals'E (E'Ok entity) = get'mVals entity+get'mVals'E (E'Error {}) = Nothing+ get'mVals :: Entity -> Maybe EMap get'mVals (E'Message {mVals = x}) = Just x get'mVals (E'Group {mVals = x}) = Just x@@ -257,15 +345,15 @@ -- | This is a helper for resolveEnv toGlobal :: Env -> Env-toGlobal (Local _entity env) = toGlobal env+toGlobal (Local _ _ env) = toGlobal env toGlobal x@(Global {}) = x getTL :: Env -> TopLevel-getTL (Local _entity env) = getTL env+getTL (Local _ _ env) = getTL env getTL (Global tl _tls) = tl getTLS :: Env -> (TopLevel,[TopLevel])-getTLS (Local _entity env) = getTLS env+getTLS (Local _ _ env) = getTLS env getTLS (Global tl tls) = (tl, tls) -- | This is used for resolving some UninterpretedOption names@@ -275,67 +363,50 @@ x <- getJust ("resolveHere: validI nameU failed for "++show nameU) (fmap iToString (validI nameU)) case get'mVals parent of Just vals -> case M.lookup x vals of- Just entity -> return entity+ Just (E'Ok entity) -> return entity+ Just (E'Error s _) -> rFail ("because the name resolved to an error:\n" ++ indent s) Nothing -> rFail ("because there is no such name here: "++show (eName parent)) Nothing -> rFail ("because environment has no local names:\n"++ishow (eName parent)) -{---- | 'resolveEnv' is the query operation for the Env namespace. It--- recorgnizes names beginning with a '.' as already being--- fully-qualified names. This is called from the different monads via--- resolveRE, resolveSE, or getType.-resolveEnv :: Utf8 -> Env -> Either ErrStr Entity-resolveEnv nameU envIn = do- (isGlobal,xs) <- checkDIUtf8 nameU- let mResult = if isGlobal then lookupEnv (map iToString xs) (toGlobal envIn)- else lookupEnv (map iToString xs) envIn- case mResult of- Nothing -> throw . unlines $ [ "resolveEnv: Could not lookup "++show nameU- , "which parses as "++show (isGlobal,xs)- , "in environment: "++(whereEnv envIn)- , "allowed: "++show (allowed envIn)]- Just (E'Error s _es) -> throw s- Just e -> return e--}--resolveEnv :: Utf8 -> Env -> Either ErrStr Entity-resolveEnv = resolvePredEnv "Any item" (const True)---- | 'resolvePred Env' is the query operation for the Env namespace. It recognizes names beginning+-- | 'resolvePredEnv' is the query operation for the Env namespace. It recognizes names beginning -- with a '.' as already being fully-qualified names. This is called from the different monads via--- resolveMGE and resolveM-resolvePredEnv :: String -> (Entity -> Bool) -> Utf8 -> Env -> Either ErrStr Entity+-- resolveEnv, resolveMGE, and resolveM+--+-- The returned (Right _::Entity) will never be an E'Error, which results in (Left _::ErrStr) instead+resolvePredEnv :: String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either ErrStr Entity resolvePredEnv userMessage accept nameU envIn = do (isGlobal,xs) <- checkDIUtf8 nameU let mResult = if isGlobal then lookupEnv (map iToString xs) (toGlobal envIn) else lookupEnv (map iToString xs) envIn case mResult of- Nothing -> throw . unlines $ [ "resolvePredEnv: Could not lookup "++show nameU- , "which parses as "++show (isGlobal,xs)- , "in environment: "++(whereEnv envIn)- , "looking for: "++userMessage- , "allowed: "++show (allowed envIn)]+ Just (E'Ok e) -> return e Just (E'Error s _es) -> throw s- Just e -> return e+ Nothing -> throw . unlines $ [ "resolvePredEnv: Could not lookup " ++ show nameU+ , "which parses as " ++ show (isGlobal,xs)+ , "in environment: " ++ (whereEnv envIn)+ , "looking for: " ++ userMessage+ , "allowed (local): " ++ show (allowedLocal envIn)+ , "allowed (global): " ++ show (allowedGlobal envIn) ] where- lookupEnv :: [IName String] -> Env -> Maybe Entity- lookupEnv xs (Global tl tls) = lookupTopLevel xs tl <|> msum (map (lookupTopLevel xs) tls)- lookupEnv _xs (Local e@(E'Error {}) _env) = return e- lookupEnv xs (Local entity env) = case get'mVals entity of- Just vals -> filteredLookup vals xs <|> lookupEnv xs env- Nothing -> Nothing+ lookupEnv :: [IName String] -> Env -> Maybe E'Entity+ lookupEnv xs (Global tl tls) = let main = top'Package tl+ findThis = lookupTopLevel main xs+ in msum (map findThis (tl:tls))+ lookupEnv xs (Local _ vals env) = filteredLookup vals xs <|> lookupEnv xs env - lookupTopLevel :: [IName String] -> TopLevel -> Maybe Entity- lookupTopLevel xs tl =- filteredLookup (top'mVals tl) xs <|> (stripPrefix (top'Package tl) xs >>= filteredLookup (top'mVals tl))+ lookupTopLevel :: [IName String] -> [IName String] -> TopLevel -> Maybe E'Entity+ lookupTopLevel main xs tl = + (if main == top'Package tl then filteredLookup (top'mVals tl) xs else Nothing)+ <|>+ (stripPrefix (top'Package tl) xs >>= filteredLookup (top'mVals tl)) filteredLookup valsIn namesIn =- let lookupVals :: EMap -> [IName String] -> Maybe Entity+ let lookupVals :: EMap -> [IName String] -> Maybe E'Entity lookupVals _vals [] = Nothing lookupVals vals [x] = M.lookup x vals lookupVals vals (x:xs) = do- entity <- M.lookup x vals- case get'mVals entity of+ entity <- M.lookup x vals+ case get'mVals'E entity of Just vals' -> lookupVals vals' xs Nothing -> Nothing m'x = lookupVals valsIn namesIn@@ -343,13 +414,15 @@ Just entity | accept entity -> m'x _ -> Nothing +-- Used in resolveRE and getType.resolveSE. Accepts all types and so commits to first hit, but+-- caller may reject some types later.+resolveEnv :: Utf8 -> Env -> Either ErrStr Entity+resolveEnv = resolvePredEnv "Any item" (const True)++-- resolveRE is the often used workhorse of the fq* family of functions resolveRE :: Utf8 -> RE Entity resolveRE nameU = lift . (resolveEnv nameU) =<< ask --- All uses of this then apply expectMGE or expectM, so provide predicate 'skip' support.-resolveSE :: Utf8 -> SE (Either ErrStr Entity)-resolveSE nameU = fmap (resolveEnv nameU) (asks my'Env)- -- | 'getType' is used to lookup the type strings in service method records. getType :: Show a => String -> (a -> Maybe Utf8) -> a -> SE (Maybe (Either ErrStr Entity)) getType s f a = do@@ -358,78 +431,27 @@ Just _ -> return Nothing Nothing -> do ee <- resolveSE typeU return (Just (expectMGE ee))--resolveMGE :: Utf8 -> SE (Either ErrStr Entity)-resolveMGE nameU = fmap (resolvePredEnv "Message or Group or Enum" isMGE nameU) (asks my'Env)- where isMGE e' = case e' of E'Message {} -> True- E'Group {} -> True- E'Enum {} -> True- _ -> False-+ where+ -- All uses of this then apply expectMGE or expectM, so provide predicate 'skip' support.+ resolveSE :: Utf8 -> SE (Either ErrStr Entity)+ resolveSE nameU = fmap (resolveEnv nameU) (asks my'Env) -- | 'expectMGE' is used by getType and 'entityField' expectMGE :: Either ErrStr Entity -> Either ErrStr Entity expectMGE ee@(Left {}) = ee-expectMGE ee@(Right e) = if isMGE e then ee- else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e) -- cannot show all of "e" because this will loop and hang the hprotoc program- where isMGE e' = case e' of E'Message {} -> True- E'Group {} -> True- E'Enum {} -> True- _ -> False----- To be used for key extendee name resolution, but not part of the official protobuf-2.1.0 update-resolveM :: Utf8 -> SE (Either ErrStr Entity)-resolveM nameU = fmap (resolvePredEnv "Message" isM nameU) (asks my'Env)- where isM e' = case e' of E'Message {} -> True- _ -> False--{---- | 'expectM' is used by 'entityField'-expectM :: Either ErrStr Entity -> Either ErrStr Entity-expectM ee@(Left {}) = ee-expectM ee@(Right e) = if isM e then ee- else Left $ "expectM: Name resolution failed to find a Message:\n"++ishow (eName e) -- cannot show all of "e" because this will loop and hang the hprotoc program- where isM e' = case e' of E'Message {} -> True- _ -> False--}--expectFK :: Entity -> RE Entity-expectFK e = if isFK e then return e- else throwError $ "expectF: Name resolution failed to find a Field or Key:\n"++ishow (eName e)- where isFK e' = case e' of E'Field {} -> True- E'Key {} -> True- _ -> False+expectMGE ee@(Right e) | isMGE = ee+ | otherwise = throw $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e)+ -- cannot show all of "e" because this will loop and hang the hprotoc program+ where isMGE = case e of E'Message {} -> True+ E'Group {} -> True+ E'Enum {} -> True+ _ -> False -- | This is a helper for resolveEnv and (Show SEnv) for error messages whereEnv :: Env -> String-whereEnv (Local entity env) = fiName (joinDot (eName entity)) ++ " in "++show (top'Path . getTL $ env)+whereEnv (Local name _ env) = fiName (joinDot name) ++ " in "++show (top'Path . getTL $ env) whereEnv (Global tl _) = fiName (joinDot (top'Package tl)) ++ " in " ++ show (top'Path tl) -{---- | lookupEnv is used only by resolveEnv-lookupEnv :: [IName String] -> Env -> Maybe Entity-lookupEnv xs (Global tl tls) = lookupTopLevel xs tl <|> msum (map (lookupTopLevel xs) tls)-lookupEnv _xs (Local e@(E'Error {}) _env) = return e-lookupEnv xs (Local entity env) = case get'mVals entity of- Just vals -> lookupVals vals xs <|> lookupEnv xs env- Nothing -> Nothing---- | lookupTopLevel is used only by lookupEnv-lookupTopLevel :: [IName String] -> TopLevel -> Maybe Entity-lookupTopLevel xs tl =- lookupVals (top'mVals tl) xs <|> (stripPrefix (top'Package tl) xs >>= lookupVals (top'mVals tl))---- | lookupVals is used by lookupEnv and lookupTopLevel-lookupVals :: EMap -> [IName String] -> Maybe Entity-lookupVals _vals [] = Nothing-lookupVals vals [x] = M.lookup x vals-lookupVals vals (x:xs) = do entity <- M.lookup x vals- case get'mVals entity of- Just vals' -> lookupVals vals' xs- Nothing -> Nothing--}- -- | 'partEither' separates the Left errors and Right success in the obvious way. partEither :: [Either a b] -> ([a],[b]) partEither [] = ([],[])@@ -440,7 +462,9 @@ -- | The 'unique' function is used with Data.Map.fromListWithKey to detect -- name collisions and record this as E'Error entries in the map.-unique :: IName String -> Entity -> Entity -> Entity+--+-- This constructs new E'Error values+unique :: IName String -> E'Entity -> E'Entity -> E'Entity unique name (E'Error _ a) (E'Error _ b) = E'Error ("Namespace collision for "++show name) (a++b) unique name (E'Error _ a) b = E'Error ("Namespace collision for "++show name) (a++[b]) unique name a (E'Error _ b) = E'Error ("Namespace collision for "++show name) (a:b)@@ -449,21 +473,38 @@ maybeM :: Monad m => (x -> m a) -> (Maybe x) -> m (Maybe a) maybeM f mx = maybe (return Nothing) (liftM Just . f) mx -runSE :: SEnv -> SE a -> Either ErrStr a-runSE sEnv m = runReaderT m sEnv+type MRM a = ReaderT ProtoName (WriterT [(FIName Utf8,ProtoName)] (Either ErrStr)) a +runMRM'Reader :: ProtoName -> MRM a -> WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) a+runMRM'Reader template mrm = runReaderT mrm template++runMRM'Writer :: WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) a -> Either ErrStr (a,[(FIName Utf8,ProtoName)])+runMRM'Writer = runWriterT++mrmName :: String -> (a -> Maybe Utf8) -> a -> MRM ProtoName+mrmName s f a = do+ template <- ask+ iSelf <- getJust s (validI =<< f a)+ let mSelf = mangle iSelf+ fqSelf = fqAppend (protobufName template) [iSelf]+ self = template { protobufName = fqSelf+ , baseName = mSelf }+ template' = template { protobufName = fqSelf+ , parentModule = parentModule template ++ [mSelf] }+ tell [(fqSelf,self)]+ return template'+ makeNameMaps :: [MName String] -> [(CanonFP,[MName String])] -> Env -> Either ErrStr NameMap makeNameMaps hPrefix hAs env = do let getPrefix fdp =- let ans = case D.FileDescriptorProto.name fdp of- Nothing -> hPrefix -- really likely to be an error elsewhere- Just n -> let path = CanonFP (toString n)- in case lookup path hAs of- Just p -> p- Nothing -> case lookup (CanonFP . Canon.takeBaseName . unCanonFP $ path) hAs of- Just p -> p- Nothing -> hPrefix- in ans + case D.FileDescriptorProto.name fdp of+ Nothing -> hPrefix -- really likely to be an error elsewhere+ Just n -> let path = CanonFP (toString n)+ in case lookup path hAs of+ Just p -> p+ Nothing -> case lookup (CanonFP . Canon.takeBaseName . unCanonFP $ path) hAs of+ Just p -> p+ Nothing -> hPrefix let (tl,tls) = getTLS env (fdp:fdps) <- mapM top'FDP (tl:tls) (NameMap tuple m) <- makeNameMap (getPrefix fdp) fdp@@ -473,9 +514,8 @@ -- | 'makeNameMap' conservatively checks its input. makeNameMap :: [MName String] -> D.FileDescriptorProto -> Either ErrStr NameMap-makeNameMap hPrefix fdpIn = -- trace (show ("getPrefix",D.FileDescriptorProto.name fdpIn,hPrefix)) $- go (makeOne fdpIn) where- go = fmap ((\(a,w) -> NameMap a (M.fromList w))) . runWriterT+makeNameMap hPrefix fdpIn = go (makeOne fdpIn) where+ go = fmap ((\(a,w) -> NameMap a (M.fromList w))) . runMRM'Writer -- makeOne :: D.FileDescriptorProto -> WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) () makeOne fdp = do -- Create 'template' :: ProtoName using "Text.ProtocolBuffers.Identifiers"@@ -491,7 +531,7 @@ let hParent = map (mangle :: IName Utf8 -> MName String) . splitDI $ diParent template = ProtoName packageName hPrefix hParent (error "makeNameMap.makeOne.template.baseName undefined")- runReaderT (mrmFile fdp) template+ runMRM'Reader template (mrmFile fdp) return (packageName,hPrefix,hParent) -- Traversal of the named DescriptorProto types mrmFile :: D.FileDescriptorProto -> MRM ()@@ -517,102 +557,102 @@ local (const template) $ F.mapM_ mrmMethod (D.ServiceDescriptorProto.method sdp) mrmMethod mdp = mrmName "mrmMethod.name" D.MethodDescriptorProto.name mdp -type MRM a = ReaderT ProtoName (WriterT [(FIName Utf8,ProtoName)] (Either ErrStr)) a--mrmName :: String -> (a -> Maybe Utf8) -> a -> MRM ProtoName-mrmName s f a = do- template <- ask- iSelf <- getJust s (validI =<< f a)- let mSelf = mangle iSelf- fqSelf = fqAppend (protobufName template) [iSelf]- self = template { protobufName = fqSelf- , baseName = mSelf }- template' = template { protobufName = fqSelf- , parentModule = parentModule template ++ [mSelf] }- tell [(fqSelf,self)]--- trace (unlines [show fqSelf,ishow self]) $ - return template'- getNames :: String -> (a -> Maybe Utf8) -> a -> SE (IName String,[IName String]) getNames errorMessage accessor record = do parent <- asks my'Parent- iSelf <- getJust errorMessage (validI =<< accessor record)- let names = parent ++ [ iToString iSelf ]- return (iToString iSelf,names)+ iSelf <- fmap iToString $ getJust errorMessage (validI =<< accessor record)+ let names = parent ++ [ iSelf ]+ return (iSelf,names) descend :: [IName String] -> Entity -> SE a -> SE a descend names entity act = local mutate act where mutate (SEnv _parent env) = SEnv parent' env' where parent' = names -- cannot call eName ename, will cause <<loop>> with "getNames" -- XXX revisit- env' = Local entity env+ env' = Local (eName entity) (mVals entity) env -- Run each element of (Seq x) as (f x) with same initial environment and state. -- Then merge the output states and sort out the failures and successes.-kids :: (x -> SE (IName String,Entity)) -> Seq x -> SE ([ErrStr],[(IName String,Entity)])+kids :: (x -> SE (IName String,E'Entity)) -> Seq x -> SE ([ErrStr],[(IName String,E'Entity)]) kids f xs = do sEnv <- ask let ans = map (runSE sEnv) . map f . F.toList $ xs return (partEither ans) --- | XXX 'makeTopLevel' takes a .proto file's FileDescriptorProto and the--- TopLevel values of its directly imported file and constructs the--- TopLevel of the FileDescriptorProto in a Global Environment.+-- | 'makeTopLevel' takes a .proto file's FileDescriptorProto and the TopLevel values of its+-- directly imported file and constructs the TopLevel of the FileDescriptorProto in a Global+-- Environment. ----- This goes to some lengths to be a total function with good error--- messages. Erros in building the skeleton of the namespace are--- detected and reported instead of returning the new 'Global'--- environment. Collisions in the namespace are only detected when--- the offending name is lookedup, it will return an E'Error entity--- with a message and list of colliding Entity items. The--- cross-linking of Entity fields may fail and this failure is stored--- in the corresponding Entity.+-- This goes to some lengths to be a total function with good error messages. Errors in building+-- the skeleton of the namespace are detected and reported instead of returning the new 'Global'+-- environment. Collisions in the namespace are only detected when the offending name is looked up,+-- and will return an E'Error entity with a message and list of colliding Entity items. The+-- cross-linking of Entity fields may fail and this failure is stored in the corresponding Entity. -- -- Also caught: name collisions in Enum definitions. ----- mdo notes: sEnv depends on global which depends on sEnv ...+-- The 'mdo' usage has been replace by modified forms of 'mfix' that will generate useful error+-- values instead of calling 'error' and halting 'hprotoc'.+-- makeTopLevel :: D.FileDescriptorProto -> [IName String] -> [TopLevel] -> Either ErrStr Env {- Global -}-makeTopLevel fdp packageName imports = mdo+makeTopLevel fdp packageName imports = do filePath <- getJust "makeTopLevel.filePath" (D.FileDescriptorProto.name fdp)- let sEnv = SEnv packageName global- -- There should be no TYPE_GROUP in the extension list here, but to be safe:- groupNamesRaw = map toString . mapMaybe D.FieldDescriptorProto.type_name- . filter (maybe False (TYPE_GROUP ==) . D.FieldDescriptorProto.type') - $ (F.toList . D.FileDescriptorProto.extension $ fdp)- groupNamesI = mapMaybe validI groupNamesRaw- groupNamesDI = mapMaybe validDI groupNamesRaw -- These fully qualified names from using hprotoc as a plugin for protoc- groupNames = groupNamesI ++ map (last . splitDI) groupNamesDI- isGroup = (`elem` groupNames)- global <- runSE sEnv (do- (bads,children) <- fmap unzip . sequence $- [ kids (entityMsg isGroup) (D.FileDescriptorProto.message_type fdp)- , kids (entityField True) (D.FileDescriptorProto.extension fdp)- , kids entityEnum (D.FileDescriptorProto.enum_type fdp)- , kids entityService (D.FileDescriptorProto.service fdp) ]- let global' = Global (TopLevel (toString filePath)- packageName- (resolveFDP fdp global')- (M.fromListWithKey unique (concat children)))- imports- bad = unlines (concat bads)- when (not (null bad)) $- throw $ "makeTopLevel.bad: Some children failed for "++show filePath++"\n"++bad- return global'- )+ let -- There should be no TYPE_GROUP in the extension list here, but to be safe:+ isGroup = (`elem` groupNames) where+ groupNamesRaw = map toString . mapMaybe D.FieldDescriptorProto.type_name+ . filter (maybe False (TYPE_GROUP ==) . D.FieldDescriptorProto.type') + $ (F.toList . D.FileDescriptorProto.extension $ fdp)+ groupNamesI = mapMaybe validI groupNamesRaw+ groupNamesDI = mapMaybe validDI groupNamesRaw -- These fully qualified names from using hprotoc as a plugin for protoc+ groupNames = groupNamesI ++ map (last . splitDI) groupNamesDI+ (bad,global) <- myFixE ("makeTopLevel myFixE",emptyEnv) $ \ global'Param ->+ let sEnv = SEnv packageName global'Param+ in runSE sEnv $ do+ (bads,children) <- fmap unzip . sequence $+ [ kids (entityMsg isGroup) (D.FileDescriptorProto.message_type fdp)+ , kids (entityField True) (D.FileDescriptorProto.extension fdp)+ , kids entityEnum (D.FileDescriptorProto.enum_type fdp)+ , kids entityService (D.FileDescriptorProto.service fdp) ]+ let bad' = unlines (concat bads)+ global' = Global (TopLevel (toString filePath)+ packageName+ (resolveFDP fdp global')+ (M.fromListWithKey unique (concat children)))+ imports+ return (bad',global')+ -- Moving this outside the myFixE reduces the cases where myFixE generates an 'error' call.+ when (not (null bad)) $+ throw $ "makeTopLevel.bad: Some children failed for "++show filePath++"\n"++bad return global -{- ***+ where resolveFDP :: D.FileDescriptorProto -> Env -> Either ErrStr D.FileDescriptorProto+ resolveFDP fdpIn env = runRE env (fqFileDP fdpIn)+ where runRE :: Env -> RE D.FileDescriptorProto -> Either ErrStr D.FileDescriptorProto+ runRE envIn m = runReaderT m envIn -All the entity* functions are used by makeTopLevel and each other.-They are very scrupulous in being total functions, there is no use of-'error' or 'undefined' and all failures (many of which are Impossible)-are reported by hopefully sensible (Left String) messages. +-- Copies of mFix for use the string in (Left msg) for the error message.+-- Note that the usual mfix for Either calls 'error' while this does not,+-- it uses a default value passed to myFix*.+myFixSE :: (String,a) -> (a -> SE (String,a)) -> SE (String,a)+myFixSE s f = ReaderT $ \r -> myFixE s (\a -> runReaderT (f a) r)++-- Note that f ignores the fst argument+myFixE :: (String,a) -> (a -> Either ErrStr (String,a)) -> Either ErrStr (String,a)+myFixE s f = let a = f (unRight a) in a+ where unRight (Right x) = snd x+ unRight (Left msg) = snd s+-- ( "Text.ProtocolBuffers.ProtoCompile.Resolve: "++fst s ++":\n" ++ indent msg+-- , snd s)++{- ***+All the entity* functions are used by makeTopLevel and each other.+If there is no error then these return (IName String,E'Entity) and this E'Entity is always E'Ok. *** -} -- Fix this to look at groupNamesDI as well as the original list of groupNamesI. This fixes a bug -- in the plug-in usage because protoc will have already resolved the type_name to a fully qualified -- name.-entityMsg :: (IName String -> Bool) -> D.DescriptorProto -> SE (IName String,Entity)-entityMsg isGroup dp = annErr ("entityMsg DescriptorProto name is "++show (D.DescriptorProto.name dp)) $ mdo+entityMsg :: (IName String -> Bool) -> D.DescriptorProto -> SE (IName String,E'Entity)+entityMsg isGroup dp = annErr ("entityMsg DescriptorProto name is "++show (D.DescriptorProto.name dp)) $ do (self,names) <- getNames "entityMsg.name" D.DescriptorProto.name dp numbers <- fmap Set.fromList . mapM (getJust "entityMsg.field.number" . D.FieldDescriptorProto.number) . F.toList . D.DescriptorProto.field $ dp when (Set.size numbers /= Seq.length (D.DescriptorProto.field dp)) $@@ -624,24 +664,24 @@ groupNamesDI = mapMaybe validDI groupNamesRaw -- These fully qualified names from using hprotoc as a plugin for protoc groupNames = groupNamesI ++ map (last . splitDI) groupNamesDI isGroup' = (`elem` groupNames)- entity <- descend names entity $ do+ (bad,entity) <- myFixSE ("myFixSE entityMsg",emptyEntity) $ \ entity'Param -> descend names entity'Param $ do (bads,children) <- fmap unzip . sequence $ [ kids entityEnum (D.DescriptorProto.enum_type dp) , kids (entityField True) (D.DescriptorProto.extension dp) , kids (entityField False) (D.DescriptorProto.field dp) , kids (entityMsg isGroup') (D.DescriptorProto.nested_type dp) ]- let entity' | isGroup self = E'Group names (M.fromListWithKey unique (concat children))+ let bad' = unlines (concat bads)+ entity' | isGroup self = E'Group names (M.fromListWithKey unique (concat children)) | otherwise = E'Message names (getExtRanges dp) (M.fromListWithKey unique (concat children))- bad = unlines (concat bads)- when (not (null bad)) $- throwError $ "entityMsg.bad: Some children failed for "++show names++"\n"++bad- return entity'- return (self,entity)+ return (bad',entity')+ -- Moving this outside the myFixSE reduces the cases where myFixSE uses the error-default call.+ when (not (null bad)) $+ throwError $ "entityMsg.bad: Some children failed for "++show names++"\n"++bad+ return (self,E'Ok $ entity) -- Among other things, this is where ambiguous type names in the proto file are resolved into a -- Message or a Group or an Enum.-{- old: Tracking error flow: if the expectMGE fails then the 'mVal' in the E'Field is a (Just (Left _)). This triggers a thrown error if accessed in 'fqField'. -}-entityField :: Bool -> D.FieldDescriptorProto -> SE (IName String,Entity)+entityField :: Bool -> D.FieldDescriptorProto -> SE (IName String,E'Entity) entityField isKey fdp = annErr ("entityField FieldDescriptorProto name is "++show (D.FieldDescriptorProto.name fdp)) $ do (self,names) <- getNames "entityField.name" D.FieldDescriptorProto.name fdp let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp)@@ -649,13 +689,29 @@ throwError $ "entityField: Impossible? Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),names,fdp) number <- getJust "entityField.name" . D.FieldDescriptorProto.number $ fdp let mType = D.FieldDescriptorProto.type' fdp--- typeName <- maybeM (fmap expectMGE . resolveSE) (D.FieldDescriptorProto.type_name fdp) typeName <- maybeM resolveMGE (D.FieldDescriptorProto.type_name fdp)- if isKey then do extendee <- resolveM =<< getJust "entityField.extendee" (D.FieldDescriptorProto.extendee fdp)- return (self,E'Key names extendee (FieldId number) mType typeName)- else return (self,E'Field names (FieldId number) mType typeName)+ if isKey+ then do+ extendee <- resolveM =<< getJust "entityField.extendee" (D.FieldDescriptorProto.extendee fdp)+ return (self,E'Ok $ E'Key names extendee (FieldId number) mType typeName)+ else+ return (self,E'Ok $ E'Field names (FieldId number) mType typeName)+ where+ resolveMGE :: Utf8 -> SE (Either ErrStr Entity)+ resolveMGE nameU = fmap (resolvePredEnv "Message or Group or Enum" isMGE nameU) (asks my'Env)+ where isMGE (E'Ok e') = case e' of E'Message {} -> True+ E'Group {} -> True+ E'Enum {} -> True+ _ -> False+ isMGE (E'Error {}) = False+ -- To be used for key extendee name resolution, but not part of the official protobuf-2.1.0 update, since made official+ resolveM :: Utf8 -> SE (Either ErrStr Entity)+ resolveM nameU = fmap (resolvePredEnv "Message" isM nameU) (asks my'Env)+ where isM (E'Ok e') = case e' of E'Message {} -> True+ _ -> False+ isM (E'Error {}) = False -entityEnum :: D.EnumDescriptorProto -> SE (IName String,Entity)+entityEnum :: D.EnumDescriptorProto -> SE (IName String,E'Entity) entityEnum edp@(D.EnumDescriptorProto {D.EnumDescriptorProto.value=vs}) = do (self,names) <- getNames "entityEnum.name" D.EnumDescriptorProto.name edp values <- mapM (getJust "entityEnum.value.number" . D.EnumValueDescriptorProto.number) . F.toList $ vs@@ -669,51 +725,52 @@ let mapping = M.fromList (zip valNames values) when (M.size mapping /= Seq.length vs) $ throwError $ "entityEnum.value.name: There must be duplicate enum names for "++show names++"\n "++show valNames- let entity = E'Enum names mapping- descend names entity $ F.mapM_ entityEnumValue vs- return (self,E'Enum names mapping) -- discard values+ descend'Enum names $ F.mapM_ entityEnumValue vs+ return (self,E'Ok $ E'Enum names mapping) -- discard values -entityEnumValue :: D.EnumValueDescriptorProto -> SE ()-entityEnumValue evdp = do -- Merely use getNames to add mangled self to ReMap state- _ <- getNames "entityEnumValue.name" D.EnumValueDescriptorProto.name evdp- return ()+ where entityEnumValue :: D.EnumValueDescriptorProto -> SE ()+ entityEnumValue evdp = do -- Merely use getNames to add mangled self to ReMap state+ _ <- getNames "entityEnumValue.name" D.EnumValueDescriptorProto.name evdp+ return () -entityService :: D.ServiceDescriptorProto -> SE (IName String,Entity)-entityService sdp = annErr ("entityService ServiceDescriptorProto name is "++show (D.ServiceDescriptorProto.name sdp)) $ mdo+ descend'Enum :: [IName String] -> SE a -> SE a+ descend'Enum names act = local mutate act+ where mutate (SEnv _parent env) = SEnv names env++entityService :: D.ServiceDescriptorProto -> SE (IName String,E'Entity)+entityService sdp = annErr ("entityService ServiceDescriptorProto name is "++show (D.ServiceDescriptorProto.name sdp)) $ do (self,names) <- getNames "entityService.name" D.ServiceDescriptorProto.name sdp- let entity = E'Service names (M.fromListWithKey unique methods)- (badMethods,methods) <- descend names entity $- kids entityMethod (D.ServiceDescriptorProto.method sdp)- when (not (null badMethods)) $- throwError $ "entityService.badMethods: Some methods failed for "++show names++"\n"++unlines badMethods- return (self,entity)+ (bad,entity) <- myFixSE ("myFixSE entityService",emptyEntity) $ \ entity'Param ->+ descend names entity'Param $ do+ (badMethods',goodMethods) <- kids entityMethod (D.ServiceDescriptorProto.method sdp)+ let bad' = unlines badMethods'+ entity' = E'Service names (M.fromListWithKey unique goodMethods)+ return (bad',entity')+ -- Moving this outside the myFixSE reduces the cases where myFixSE generates an 'error' call.+ when (not (null bad)) $+ throwError $ "entityService.badMethods: Some methods failed for "++show names++"\n"++bad+ return (self,E'Ok entity) -entityMethod :: D.MethodDescriptorProto -> SE (IName String,Entity)+entityMethod :: D.MethodDescriptorProto -> SE (IName String,E'Entity) entityMethod mdp = do (self,names) <- getNames "entityMethod.name" D.MethodDescriptorProto.name mdp inputType <- getType "entityMethod.input_type" D.MethodDescriptorProto.input_type mdp outputType <- getType "entityMethod.output_type" D.MethodDescriptorProto.output_type mdp- return (self,E'Method names inputType outputType)+ return (self,E'Ok $ E'Method names inputType outputType) {- *** -The namespace Env is used to transform the original-FileDescriptorProto into a canonical FileDescriptorProto. The new goal-is to match the transformation done by Google's protoc program. This-will allow the "front end" vs "back end" of each program to-cross-couple, which will at least allow better testing of hprotoc and-the new UninterpretedOption support.+The namespace Env is used to transform the original FileDescriptorProto into a canonical+FileDescriptorProto. The goal is to match the transformation done by Google's protoc program. This+will allow the "front end" vs "back end" of each program to cross-couple, which will at least allow+better testing of hprotoc and the new UninterpretedOption support. The UninterpretedOption fields are converted by the resolveFDP code below. -These should be total functions with no 'error' or 'undefined' values-possible.+These should be total functions with no 'error' or 'undefined' values possible. *** -} -resolveFDP :: D.FileDescriptorProto -> Env -> Either ErrStr D.FileDescriptorProto-resolveFDP = runReaderT . fqFileDP - fqFail :: Show a => String -> a -> Entity -> RE b fqFail msg dp entity = do env <- ask@@ -733,11 +790,11 @@ fqMessage :: D.DescriptorProto -> RE D.DescriptorProto fqMessage dp = annErr ("fqMessage DescriptorProto name is "++show (D.DescriptorProto.name dp)) $ do entity <- resolveRE =<< getJust "fqMessage.name" (D.DescriptorProto.name dp)- case entity of- E'Message {} -> return ()- E'Group {} -> return ()- _ -> fqFail "fqMessage.entity: did not resolve to an E'Message or E'Group:" dp entity- local (\env -> (Local entity env)) $ do+ (name,vals) <- case entity of+ E'Message {eName=name',mVals=vals'} -> return (name',vals')+ E'Group {eName=name',mVals=vals'} -> return (name',vals')+ _ -> fqFail "fqMessage.entity: did not resolve to an E'Message or E'Group:" dp entity+ local (\env -> (Local name vals env)) $ do newFields <- T.mapM (fqField False) (D.DescriptorProto.field dp) newKeys <- T.mapM (fqField True) (D.DescriptorProto.extension dp) newMessages <- T.mapM fqMessage (D.DescriptorProto.nested_type dp)@@ -751,30 +808,33 @@ fqService sdp = annErr ("fqService ServiceDescriptorProto name is "++show (D.ServiceDescriptorProto.name sdp)) $ do entity <- resolveRE =<< getJust "fqService.name" (D.ServiceDescriptorProto.name sdp) case entity of- E'Service {} -> do newMethods <- local (Local entity) $ T.mapM fqMethod (D.ServiceDescriptorProto.method sdp)- consumeUNO $ sdp { D.ServiceDescriptorProto.method = newMethods }+ E'Service {eName=name,mVals=vals} -> do+ newMethods <- local (Local name vals) $ T.mapM fqMethod (D.ServiceDescriptorProto.method sdp)+ consumeUNO $ sdp { D.ServiceDescriptorProto.method = newMethods } _ -> fqFail "fqService.entity: did not resolve to a service:" sdp entity fqMethod :: D.MethodDescriptorProto -> RE D.MethodDescriptorProto fqMethod mdp = do entity <- resolveRE =<< getJust "fqMethod.name" (D.MethodDescriptorProto.name mdp) case entity of- E'Method {} -> do mdp1 <- case eMsgIn entity of- Nothing -> return mdp- Just resolveIn -> do new <- fmap fqName (lift resolveIn)- return (mdp {D.MethodDescriptorProto.input_type = Just (fiName new)})- mdp2 <- case eMsgOut entity of- Nothing -> return mdp1- Just resolveIn -> do new <- fmap fqName (lift resolveIn)- return (mdp1 {D.MethodDescriptorProto.output_type = Just (fiName new)})- consumeUNO mdp2+ E'Method {eMsgIn=msgIn,eMsgOut=msgOut} -> do+ mdp1 <- case msgIn of+ Nothing -> return mdp+ Just resolveIn -> do+ new <- fmap fqName (lift resolveIn)+ return (mdp {D.MethodDescriptorProto.input_type = Just (fiName new)})+ mdp2 <- case msgOut of+ Nothing -> return mdp1+ Just resolveIn -> do+ new <- fmap fqName (lift resolveIn)+ return (mdp1 {D.MethodDescriptorProto.output_type = Just (fiName new)})+ consumeUNO mdp2 _ -> fqFail "fqMethod.entity: did not resolve to a Method:" mdp entity --- The field is a bit more complicated to resolve. The Key variant--- needs to resolve the extendee. The type code from Parser.hs might--- be Nothing and this needs to be resolved to TYPE_MESSAGE or--- TYPE_ENUM, and if it is the latter then any default value string is--- checked for validity.+-- The field is a bit more complicated to resolve. The Key variant needs to resolve the extendee.+-- The type code from Parser.hs might be Nothing and this needs to be resolved to TYPE_MESSAGE or+-- TYPE_ENUM (at last!), and if it is the latter then any default value string is checked for+-- validity. fqField :: Bool -> D.FieldDescriptorProto -> RE D.FieldDescriptorProto fqField isKey fdp = annErr ("fqField FieldDescriptorProto name is "++show (D.FieldDescriptorProto.name fdp)) $ do let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp)@@ -782,12 +842,15 @@ ask >>= \env -> throwError $ "fqField.isKey: Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),whereEnv env,fdp) entity <- expectFK =<< resolveRE =<< getJust "fqField.name" (D.FieldDescriptorProto.name fdp) newExtendee <- case (isKey,entity) of- (True,E'Key {}) -> do- ext <- lift (eMsg entity)+ (True,E'Key {eMsg=msg,fNumber=fNum}) -> do+ ext <- lift msg case ext of- E'Message {} -> when (not (checkFI (validExtensions ext) (fNumber entity))) $+ E'Message {} -> when (not (checkFI (validExtensions ext) fNum)) $ throwError $ "fqField.newExtendee: Field Number of extention key invalid:\n"- ++unlines ["Number is "++show (fNumber entity),"Valid ranges: "++show (validExtensions ext),"Extendee: "++show (eName ext),"Descriptor: "++show fdp]+ ++unlines ["Number is "++show (fNumber entity)+ ,"Valid ranges: "++show (validExtensions ext)+ ,"Extendee: "++show (eName ext)+ ,"Descriptor: "++show fdp] _ -> fqFail "fqField.ext: Key's target is not an E'Message:" fdp ext fmap (Just . fiName . fqName) . lift . eMsg $ entity (False,E'Field {}) -> return Nothing@@ -829,14 +892,31 @@ else (fdp { D.FieldDescriptorProto.type' = Just actualType , D.FieldDescriptorProto.type_name = fmap (fiName . fqName) mTypeName }) -isNotPacked :: D.FieldDescriptorProto -> Bool-isNotPacked (D.FieldDescriptorProto { D.FieldDescriptorProto.options = Just (D.FieldOptions { D.FieldOptions.packed = Just isPacked }) }) = not isPacked-isNotPacked _ = True+ where isRepeated :: D.FieldDescriptorProto -> Bool+ isRepeated (D.FieldDescriptorProto {+ D.FieldDescriptorProto.label =+ Just LABEL_REPEATED }) =+ True+ isRepeated _ = False -isRepeated :: D.FieldDescriptorProto -> Bool-isRepeated (D.FieldDescriptorProto { D.FieldDescriptorProto.label = Just LABEL_REPEATED } ) = True-isRepeated _ = False+ isNotPacked :: D.FieldDescriptorProto -> Bool+ isNotPacked (D.FieldDescriptorProto { + D.FieldDescriptorProto.options =+ Just (D.FieldOptions { + D.FieldOptions.packed =+ Just isPacked })}) =+ not isPacked+ isNotPacked _ = True + expectFK :: Entity -> RE Entity+ expectFK e | isFK = return e+ | otherwise = throwError $ "expectF: Name resolution failed to find a Field or Key:\n"++ishow (eName e)+ where isFK = case e of E'Field {} -> True+ E'Key {} -> True+ _ -> False+++ fqEnum :: D.EnumDescriptorProto -> RE D.EnumDescriptorProto fqEnum edp = do entity <- resolveRE =<< getJust "fqEnum.name" (D.EnumDescriptorProto.name edp)@@ -845,7 +925,7 @@ consumeUNO $ edp { D.EnumDescriptorProto.value = evdps } _ -> fqFail "fqEnum.entity: did not resolve to an E'Enum:" edp entity -{- The consumeUNO calls above hide this cut-and-pasted boilerplate -}+{- The consumeUNO calls above hide this cut-and-pasted boilerplate between interpretOptions and the DescriptorProto type -} class ConsumeUNO a where consumeUNO :: a -> RE a @@ -934,10 +1014,11 @@ , " message: "++msg ] -- This takes care of an intermediate message or group type- go :: Maybe Entity -> [IName String] -> D.NamePart -> [D.NamePart] -> RE (FieldId,ExtFieldValue)+ go :: Maybe Entity {- E'Message E'Group -} -> [IName String] -> D.NamePart -> [D.NamePart] -> RE (FieldId,ExtFieldValue) go mParent names (D.NamePart { D.NamePart.name_part = name , D.NamePart.is_extension = isKey }) (next:rest) = do -- get entity (Field or Key) and the TYPE_*+ -- fk will ceratinly be E'Field or E'Key (fk,entity) <- if not isKey then case mParent of@@ -945,40 +1026,40 @@ Just parent -> do entity'field <- resolveHere parent name case entity'field of- E'Field {} -> case mVal entity'field of- Nothing -> iFail $ "Intermediate entry E'Field is of basic type, not E'Message or E'Group: "++show (names,eName entity'field)- Just val -> lift val >>= \e -> return (entity'field,e)+ (E'Field {}) ->+ case mVal entity'field of+ Nothing -> iFail $ "Intermediate entry E'Field is of basic type, not E'Message or E'Group: "++show (names,eName entity'field)+ Just val -> lift val >>= \e -> return (entity'field,e) _ -> iFail $ "Name "++show (toString name)++" was resolved but was not an E'Field: "++show (eName entity'field) else do entity'key <- resolveRE name case entity'key of- E'Key {} -> do extendee <- lift (eMsg entity'key)- when (eName extendee /= names) $- iFail $ "Intermediate entry E'Key extends wrong type: "++show (names,eName extendee)- case mVal entity'key of- Nothing-> iFail $ "Intermediate entry E'Key is of basic type, not E'Message or E'Group: "++show (names,eName entity'key)- Just val -> lift val >>= \e -> return (entity'key,e)+ (E'Key {eMsg=msg}) -> do+ extendee <- lift msg+ when (eName extendee /= names) $+ iFail $ "Intermediate entry E'Key extends wrong type: "++show (names,eName extendee)+ case mVal entity'key of+ Nothing-> iFail $ "Intermediate entry E'Key is of basic type, not E'Message or E'Group: "++show (names,eName entity'key)+ Just val -> lift val >>= \e -> return (entity'key,e) _ -> iFail $ "Name "++show (toString name)++" was resolved but was not an E'Key: "++show (eName entity'key) t <- case entity of E'Message {} -> return TYPE_MESSAGE E'Group {} -> return TYPE_GROUP _ -> iFail $ "Intermediate entry is not an E'Message or E'Group: "++show (eName entity) -- recursive call to get inner result--- (fid',ExtFromWire wt' raw') <- go (Just entity) (eName entity) next rest (fid',ExtFromWire raw') <- go (Just entity) (eName entity) next rest -- wrap old tag + inner result with outer info- let tag' = getWireTag (mkWireTag fid' wt')+ let tag@(WireTag tag') = mkWireTag fid' wt' (EP wt' bs') = Seq.index raw' 0- let fid = fNumber fk+ let fid = fNumber fk -- safe by construction of fk wt = toWireType (FieldType (fromEnum t)) bs = runPut $- case t of TYPE_MESSAGE -> do putSize (size'Varint tag' + LC.length bs')+ case t of TYPE_MESSAGE -> do putSize (size'WireTag tag + LC.length bs') putVarUInt tag' putLazyByteString bs' TYPE_GROUP -> do putVarUInt tag' putLazyByteString bs' putVarUInt (succ (getWireTag (mkWireTag fid wt))) _ -> fail $ "bug! raw with type "++show t++" should be impossible"--- return (fid,ExtFromWire wt raw) return (fid,ExtFromWire (Seq.singleton (EP wt bs))) -- This takes care of the acutal value of the option, which must be a basic type@@ -996,9 +1077,9 @@ when (eName ext /= names) $ iFail $ "Last entry E'Key extends wrong type: "++show (names,eName ext) _ -> iFail $ "Last entity was resolved but was not an E'Field or E'Key: "++show fk t <- case (fType fk) of- Nothing -> return TYPE_ENUM- Just TYPE_GROUP -> iFail $ "Last entry was a TYPE_GROUP instead of concrete value type"- Just TYPE_MESSAGE -> {- impossible -} iFail $ "Last entry was a TYPE_MESSAGE instead of concrete value type"+ Nothing -> return TYPE_ENUM -- XXX not a good assumption with aggregate types !!!! This also covers groups and messages.+ Just TYPE_GROUP -> iFail $ "Last entry was a TYPE_GROUP instead of concrete value type" -- impossible+ Just TYPE_MESSAGE -> {- impossible -} iFail $ "Last entry was a TYPE_MESSAGE instead of concrete value type" -- impossible Just typeCode -> return typeCode -- Need to define a polymorphic 'done' to convert actual data type to its wire encoding let done :: Wire v => v -> RE (FieldId,ExtFieldValue)@@ -1008,20 +1089,32 @@ in return (fid,ExtFromWire (Seq.singleton (EP wt (runPut (wirePut ft v))))) -- The actual type and value fed to 'done' depends on the values 't' and 'uno': case t of- TYPE_ENUM ->- case (mVal fk,D.UninterpretedOption.identifier_value uno) of- (Just (Right (E'Enum {eVals=enumVals})),Just enumVal) ->+ TYPE_ENUM -> -- Now must also also handle Message and Group+ case (mVal fk,D.UninterpretedOption.identifier_value uno,D.UninterpretedOption.aggregate_value uno) of+ (Just (Right (E'Enum {eVals=enumVals})),Just enumVal,_) -> case validI enumVal of Nothing -> iFail $ "invalid D.UninterpretedOption.identifier_value: "++show enumVal Just enumIVal -> case M.lookup enumIVal enumVals of Nothing -> iFail $ "enumVal lookup failed: "++show (enumIVal,M.keys enumVals) Just val -> done (fromEnum val) -- fromEnum :: Int32 -> Int- (Just (Right (E'Enum {})),Nothing) -> iFail $ "No identifer_value value to lookup in E'Enum"- (me,_) -> iFail $ "Expected Just E'Enum, got: "++show me+ (Just (Right (E'Enum {})),Nothing,_) -> iFail $ "No identifer_value value to lookup in E'Enum"+ (Just (Right (E'Message {})),_,Nothing) -> iFail "Expected aggregate syntax to set a message option"+ (Just (Right (E'Message {})),_,Just aggVal) -> iFail $ "\n\n\+ \=========================================================================================\n\+ \Google's 2.4.0 aggregate syntax for message options is not yet supported, value would be:\n\+ \=========================================================================================\n" ++ show aggVal+ (Just (Right (E'Group {})),_,Nothing) -> iFail "Expected aggregate syntax to set a group option (impossible?)"+ (Just (Right (E'Group {})),_,Just aggVal) -> iFail $ "\n\n\+ \=========================================================================================\n\+ \Google's 2.4.0 aggregate syntax for message options is not yet supported, value would be:\n\+ \=========================================================================================\n" ++ show aggVal+ (me,_,_) -> iFail $ "Expected Just E'Enum or E'Message or E'Group, got:\n"++show me+ TYPE_STRING -> do bs <- getJust "UninterpretedOption.string_value" (D.UninterpretedOption.string_value uno) maybe (done (Utf8 bs)) (\i -> iFail $ "Invalid utf8 in string_value at index: "++show i) (isValidUTF8 bs)+ TYPE_BYTES -> done =<< getJust "UninterpretedOption.string_value" (D.UninterpretedOption.string_value uno) TYPE_BOOL -> done =<< bVal TYPE_DOUBLE -> done =<< dVal@@ -1040,7 +1133,8 @@ -- Machinery needed by the final call of go bVal :: RE Bool- bVal = let true = Utf8 (U.fromString "true"); false = Utf8 (U.fromString "false")+ bVal = let true = Utf8 (U.fromString "true")+ false = Utf8 (U.fromString "false") in case D.UninterpretedOption.identifier_value uno of Just s | s == true -> return True | s == false -> return False@@ -1115,7 +1209,9 @@ Nothing -> do (parsed'fdp, canonicalFile) <- lift $ fdpReader file packageName <- either (loadFailed canonicalFile . show) (return . map iToString . snd) $- (checkDIUtf8 (getPackage parsed'fdp)) -- =<< getJust "makeTopLevel.packageName: you need a pacakge declaration in your proto file" (D.FileDescriptorProto.package parsed'fdp))+ (checkDIUtf8 (getPackage parsed'fdp))+ -- =<< getJust "makeTopLevel.packageName: you need a package declaration in your proto file"+ -- (D.FileDescriptorProto.package parsed'fdp)) let parents = Set.insert file parentsIn importList = map (fpCanonToLocal . CanonFP . toString) . F.toList . D.FileDescriptorProto.dependency $ parsed'fdp imports <- mapM (fmap getTL . load parents) importList@@ -1155,3 +1251,6 @@ fdpsByName = M.fromList . map keyByName . F.toList . CGR.proto_file $ req keyByName fdp = (fdpName fdp, fdp) fdpName = LocalFP . maybe "" (LC.unpack . utf8) . D.FileDescriptorProto.name++-- wart: descend should take (eName,eMvals) not Entity+-- wart: myFix* obviously implements a WriterT by hand. Implement as WriterT ?
hprotoc.cabal view
@@ -1,5 +1,5 @@ name: hprotoc-version: 2.0.2+version: 2.0.5 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -22,14 +22,14 @@ description: Choose the new smaller, split-up base package. Executable hprotoc+ build-depends: protocol-buffers == 2.0.5,+ protocol-buffers-descriptor == 2.0.5 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex ghc-options: -O2 -Wall -fspec-constr-count=10 ghc-prof-options: -O2 -auto-all -prof- build-depends: protocol-buffers == 2.0.2,- protocol-buffers-descriptor == 2.0.2 build-depends: array, binary, bytestring,