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 @@ -40,7 +40,7 @@ import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Reflections import Text.ProtocolBuffers.WireMessage(size'WireTag,toWireTag,toPackedWireTag,runPut,Wire(..)) -import Text.ProtocolBuffers.ProtoCompile.Resolve(ReMap,NameMap(..),PackageID(..)) +import Text.ProtocolBuffers.ProtoCompile.Resolve(ReMap,NameMap(..),getPackageID) import qualified Data.Foldable as F(foldr,toList) import qualified Data.Sequence as Seq(fromList,empty,singleton,null) @@ -124,6 +124,10 @@ keyExtendee' reMap f = case D.FieldDescriptorProto.extendee f of Nothing -> imp $ "keyExtendee expected Just but found Nothing: "++show f Just extName -> toHaskell reMap (FIName extName) + -- let debugMsg = unlines [ "MakeReflections.keyExtendee'.debugMsg" + -- , "extName is " ++ show extName + -- , "reMap is :" + -- , show reMap ] makeDescriptorInfo' :: ReMap -> FIName Utf8 -> (ProtoName -> Seq FieldInfo) 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 @@ -95,7 +95,7 @@ -- -- 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 +module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,loadCodeGenRequest,makeNameMaps,getTLS,getPackageID ,Env(..),TopLevel(..),ReMap,NameMap(..),PackageID(..),LocalFP(..),CanonFP(..)) where import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto) @@ -170,6 +170,8 @@ 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 @@ -202,14 +204,19 @@ -- change this to track the additional complexity. --newtype PackageID a = PackageID { getPackageID :: a } deriving (Show) -data PackageID a = PackageID { getPackageID :: a } - | NoPackageID { getPackageID :: a } +data PackageID a = PackageID { _getPackageID :: a } + | NoPackageID { _getNoPackageID :: a } deriving (Show) -mPackageID :: Monoid a => PackageID a -> a -mPackageID (PackageID {getPackageID=x}) = x -mPackageID (NoPackageID {}) = mempty +instance Functor PackageID where + fmap f (PackageID a) = PackageID (f a) + fmap f (NoPackageID a) = NoPackageID (f a) +-- Used in MakeReflections.makeProtoInfo +getPackageID :: PackageID a -> a +getPackageID (PackageID a) = a +getPackageID (NoPackageID a) = a + -- The package field of FileDescriptorProto is set in Parser.hs. -- 'getPackage' is the only direct user of this information in hprotoc. -- The convertFileToPackage was developed looking at the Java output of Google's protoc. @@ -224,12 +231,14 @@ Nothing -> NoPackageID defaultPackageName Just name -> NoPackageID name -getPackageUtf8 :: PackageID Utf8 -> Utf8 -getPackageUtf8 (PackageID {getPackageID=x}) = x -getPackageUtf8 (NoPackageID {getPackageID=x}) = x +--getPackageUtf8 :: PackageID Utf8 -> Utf8 +--getPackageUtf8 (PackageID {_getPackageID=x}) = x +--getPackageUtf8 (NoPackageID {_getNoPackageID=x}) = x -checkPackageID :: PackageID Utf8 -> Either String (Bool,[IName Utf8]) -checkPackageID = checkDIUtf8 . getPackageUtf8 +-- LOSES PackageID vs NoPackageID 2012-09-19 +checkPackageID :: PackageID Utf8 -> Either String (PackageID (Bool,[IName Utf8])) +checkPackageID (PackageID a) = fmap PackageID (checkDIUtf8 a) +checkPackageID (NoPackageID a) = fmap NoPackageID (checkDIUtf8 a) -- | 'convertFileToPackage' mimics what I observe protoc --java_out do to convert the file name to a -- class name. @@ -356,11 +365,10 @@ , [MName String] -- hPrefix from command line , [MName String]) -- hParent from java_outer_classname, java_package, or 'getPackage' ReMap + deriving (Show) type RE a = ReaderT Env (Either ErrStr) a -get'SEnv'root'from'PackageID :: PackageID [IName String] -> [IName String] -get'SEnv'root'from'PackageID = mPackageID data SEnv = SEnv { my'Parent :: [IName String] -- top level value is derived from PackageID , my'Env :: Env } @@ -459,13 +467,13 @@ (if matchesMain main (top'Package tl) then filteredLookup (top'mVals tl) xs else Nothing) <|> (matchPrefix (top'Package tl) xs >>= filteredLookup (top'mVals tl)) - where matchesMain (PackageID {getPackageID=a}) (PackageID {getPackageID=b}) = a==b - matchesMain (NoPackageID {}) (PackageID {}) = False + where matchesMain (PackageID {_getPackageID=a}) (PackageID {_getPackageID=b}) = a==b + matchesMain (NoPackageID {}) (PackageID {}) = False -- XXX XXX XXX 2012-09-19 suspicious matchesMain (PackageID {}) (NoPackageID {}) = True matchesMain (NoPackageID {}) (NoPackageID {}) = True matchPrefix (NoPackageID {}) _ = Nothing - matchPrefix (PackageID {getPackageID=a}) ys = stripPrefix a ys + matchPrefix (PackageID {_getPackageID=a}) ys = stripPrefix a ys filteredLookup valsIn namesIn = let lookupVals :: EMap -> [IName String] -> Maybe E'Entity @@ -520,8 +528,8 @@ -- WAS whereEnv (Global tl _) = fiName (joinDot (getPackageID (top'Package tl))) ++ " in " ++ show (top'Path tl) whereEnv (Global tl _) = formatPackageID ++ " in " ++ show (top'Path tl) where formatPackageID = case top'Package tl of - PackageID {getPackageID=x} -> fiName (joinDot x) - NoPackageID {getPackageID=y} -> show y + PackageID {_getPackageID=x} -> fiName (joinDot x) + NoPackageID {_getNoPackageID=y} -> show y -- | 'partEither' separates the Left errors and Right success in the obvious way. partEither :: [Either a b] -> ([a],[b]) @@ -589,7 +597,9 @@ (NameMap tuple m) <- makeNameMap (getPrefix fdp) fdp let f (NameMap _ x) = x ms <- fmap (map f) . mapM (\y -> makeNameMap (getPrefix y) y) $ fdps - return (NameMap tuple (M.unions (m:ms))) + let nameMap = (NameMap tuple (M.unions (m:ms))) +-- trace (show nameMap) $ + return nameMap -- | 'makeNameMap' conservatively checks its input. makeNameMap :: [MName String] -> D.FileDescriptorProto -> Either ErrStr NameMap @@ -606,11 +616,13 @@ Nothing -> FIName $ fromString "" Just p -> difi $ DIName p -} - let packageName@(PackageID fi'package'name) = PackageID (difi (DIName (getPackageUtf8 rawPackage))) :: PackageID (FIName Utf8) + let packageName :: PackageID (FIName Utf8) + packageName = fmap (difi . DIName) rawPackage + fi'package'name = getPackageID packageName rawParent <- getJust "makeNameMap.makeOne: impossible Nothing found" . msum $ [ D.FileOptions.java_outer_classname =<< (D.FileDescriptorProto.options fdp) , D.FileOptions.java_package =<< (D.FileDescriptorProto.options fdp) - , Just (getPackageUtf8 rawPackage)] + , Just (getPackageID rawPackage)] diParent <- getJust ("makeNameMap.makeOne: invalid character in: "++show rawParent) (validDI rawParent) let hParent = map (mangle :: IName Utf8 -> MName String) . splitDI $ diParent @@ -677,6 +689,7 @@ -- The 'mdo' usage has been replace by modified forms of 'mfix' that will generate useful error -- values instead of calling 'error' and halting 'hprotoc'. -- +-- Used from loadProto' makeTopLevel :: D.FileDescriptorProto -> PackageID [IName String] -> [TopLevel] -> Either ErrStr Env {- Global -} makeTopLevel fdp packageName imports = do filePath <- getJust "makeTopLevel.filePath" (D.FileDescriptorProto.name fdp) @@ -713,7 +726,16 @@ where runRE :: Env -> RE D.FileDescriptorProto -> Either ErrStr D.FileDescriptorProto runRE envIn m = runReaderT m envIn + -- Used from makeTopLevel, from loadProto' + get'SEnv'root'from'PackageID :: PackageID [IName String] -> [IName String] + get'SEnv'root'from'PackageID = getPackageID -- was mPackageID before 2012-09-19 + -- where + -- Used from get'SEnv makeTopLevel, from loadProto' + -- mPackageID :: Monoid a => PackageID a -> a + -- mPackageID (PackageID {_getPackageID=x}) = x + -- mPackageID (NoPackageID {}) = mempty + -- 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*. @@ -1295,8 +1317,16 @@ (parsed'fdp, canonicalFile) <- lift $ fdpReader file let rawPackage = getPackage parsed'fdp packageName <- either (loadFailed canonicalFile . show) - (return . PackageID . map iToString . snd) + (return . fmap (map iToString . snd)) -- 2012-09-19 suspicious (checkPackageID rawPackage) + +{- +-- OLD before 2012-09-19 + packageName <- either (loadFailed canonicalFile . show) + (return . PackageID . map iToString . snd) -- 2012-09-19 suspicious + (checkPackageID rawPackage) +-} + {- -- previously patched solution packageName <- case D.FileDescriptorProto.package parsed'fdp of diff --git a/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs b/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs --- a/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs +++ b/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs @@ -56,7 +56,7 @@ -- ----------------------------------------------------------------------------- -- The input type -{-# LINE 71 "templates/wrappers.hs" #-} +{-# LINE 72 "templates/wrappers.hs" #-} type AlexInput = (AlexPosn, -- current position, @@ -75,9 +75,9 @@ in p' `seq` cs' `seq` Just (b, (p', c, cs')) -{-# LINE 102 "templates/wrappers.hs" #-} +{-# LINE 103 "templates/wrappers.hs" #-} -{-# LINE 117 "templates/wrappers.hs" #-} +{-# LINE 118 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions @@ -105,27 +105,27 @@ -- ----------------------------------------------------------------------------- -- Default monad -{-# LINE 230 "templates/wrappers.hs" #-} +{-# LINE 231 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 319 "templates/wrappers.hs" #-} +{-# LINE 320 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 345 "templates/wrappers.hs" #-} +{-# LINE 346 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 363 "templates/wrappers.hs" #-} +{-# LINE 364 "templates/wrappers.hs" #-} -{-# LINE 376 "templates/wrappers.hs" #-} +{-# LINE 377 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- @@ -133,7 +133,7 @@ -- Adds text positions to the basic model. -{-# LINE 393 "templates/wrappers.hs" #-} +{-# LINE 394 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -1,5 +1,5 @@ name: hprotoc -version: 2.0.11 +version: 2.0.12 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -8,8 +8,8 @@ author: Christopher Edward Kuklewicz maintainer: Chris Kuklewicz stability: Experimental -homepage: http://hackage.haskell.org/package/hprotoc -package-url: http://code.haskell.org/protocol-buffers/ +homepage: http://code.haskell.org/protocol-buffers/ +package-url: http://hackage.haskell.org/package/hprotoc synopsis: Parse Google Protocol Buffer specifications description: Parse language defined at "http://code.google.com/apis/protocolbuffers/docs/proto.html" and general haskell code to implement messages. category: Text @@ -22,8 +22,8 @@ description: Choose the new smaller, split-up base package. Executable hprotoc - build-depends: protocol-buffers == 2.0.11, - protocol-buffers-descriptor == 2.0.11 + build-depends: protocol-buffers == 2.0.12, + protocol-buffers-descriptor == 2.0.12 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell