diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/Text/ProtocolBuffers/ProtoCompile/Lexer.x b/Text/ProtocolBuffers/ProtoCompile/Lexer.x --- a/Text/ProtocolBuffers/ProtoCompile/Lexer.x +++ b/Text/ProtocolBuffers/ProtoCompile/Lexer.x @@ -32,7 +32,7 @@ @inStr = @hexEscape | @octEscape | @charEscape | [^'\"\0\n] @strLit = ['] (@inStr | [\"])* ['] | [\"] (@inStr | ['])* [\"] -$special = [=\(\)\,\;\[\]\{\}\.] +$special = [=\(\)\,\;\[\]\{\}\.\:] @ninf = [\-][i][n][f] diff --git a/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs b/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs --- a/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +++ b/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs @@ -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 diff --git a/Text/ProtocolBuffers/ProtoCompile/Parser.hs b/Text/ProtocolBuffers/ProtoCompile/Parser.hs --- a/Text/ProtocolBuffers/ProtoCompile/Parser.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Parser.hs @@ -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? diff --git a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs --- a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs @@ -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 <> 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 ? diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -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,