packages feed

protocol-buffers 0.0.5 → 0.1.0

raw patch · 63 files changed

+8549/−700 lines, 63 filesdep +binarydep +binary-strict

Dependencies added: binary, binary-strict

Files

LICENSE view
@@ -8,3 +8,207 @@     * Neither the name of the copyright holder nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission.  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++The descriptor.proto and unittest.proto files from google's code are under the Apache license (2.0):++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
Text/DescriptorProtos/DescriptorProto.hs view
@@ -1,25 +1,104 @@-module Text.DescriptorProtos.DescriptorProto-  (DescriptorProto(..))- where--import Text.ProtocolBuffers.Header-import qualified Text.DescriptorProtos.FileOptions as DescriptorProtos(FileOptions)-import qualified Text.DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) -import qualified Text.DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) -import qualified Text.DescriptorProtos.MessageOptions as DescriptorProtos(MessageOptions)-import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as DescriptorProtos.DescriptorProto(ExtensionRange)--data DescriptorProto = DescriptorProto-    { name :: Maybe ByteString-    , field :: Seq DescriptorProtos.FieldDescriptorProto-    , extension :: Seq DescriptorProtos.FieldDescriptorProto-    , nested_type :: Seq DescriptorProto-    , enum_type :: Seq DescriptorProtos.EnumDescriptorProto-    , extension_range :: Seq DescriptorProtos.DescriptorProto.ExtensionRange-    , options :: Maybe DescriptorProtos.MessageOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''DescriptorProto )--instance Default DescriptorProto where+module Text.DescriptorProtos.DescriptorProto (DescriptorProto(..))+       where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.EnumDescriptorProto+       as DescriptorProtos (EnumDescriptorProto)+import qualified Text.DescriptorProtos.FieldDescriptorProto+       as DescriptorProtos (FieldDescriptorProto)+import qualified Text.DescriptorProtos.MessageOptions+       as DescriptorProtos (MessageOptions)+import qualified+       Text.DescriptorProtos.DescriptorProto.ExtensionRange+       as DescriptorProtos.DescriptorProto (ExtensionRange)+ +data DescriptorProto = DescriptorProto{name ::+                                       P'.Maybe P'.ByteString,+                                       field :: P'.Seq DescriptorProtos.FieldDescriptorProto,+                                       extension :: P'.Seq DescriptorProtos.FieldDescriptorProto,+                                       nested_type :: P'.Seq DescriptorProto,+                                       enum_type :: P'.Seq DescriptorProtos.EnumDescriptorProto,+                                       extension_range ::+                                       P'.Seq DescriptorProtos.DescriptorProto.ExtensionRange,+                                       options :: P'.Maybe DescriptorProtos.MessageOptions}+                     deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable DescriptorProto where+        mergeEmpty+          = DescriptorProto P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+        mergeAppend (DescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7)+          (DescriptorProto y'1 y'2 y'3 y'4 y'5 y'6 y'7)+          = DescriptorProto (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+              (P'.mergeAppend x'4 y'4)+              (P'.mergeAppend x'5 y'5)+              (P'.mergeAppend x'6 y'6)+              (P'.mergeAppend x'7 y'7)+ +instance P'.Default DescriptorProto where+        defaultValue+          = DescriptorProto (P'.Just P'.defaultValue) (P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire DescriptorProto where+        wireSize 11 (DescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeRep 1 11 x'2 ++                 P'.wireSizeRep 1 11 x'3+                 + P'.wireSizeRep 1 11 x'4+                 + P'.wireSizeRep 1 11 x'5+                 + P'.wireSizeRep 1 11 x'6+                 + P'.wireSizeOpt 1 11 x'7)+        wirePut 11 self'@(DescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutRep 18 11 x'2+               P'.wirePutRep 50 11 x'3+               P'.wirePutRep 26 11 x'4+               P'.wirePutRep 34 11 x'5+               P'.wirePutRep 42 11 x'6+               P'.wirePutOpt 58 11 x'7+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{field = P'.append (field old'Self) new'Field})+                               (P'.wireGet 11)+                        6 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{extension = P'.append (extension old'Self) new'Field})+                               (P'.wireGet 11)+                        3 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{nested_type =+                                             P'.append (nested_type old'Self) new'Field})+                               (P'.wireGet 11)+                        4 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{enum_type = P'.append (enum_type old'Self) new'Field})+                               (P'.wireGet 11)+                        5 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{extension_range =+                                             P'.append (extension_range old'Self) new'Field})+                               (P'.wireGet 11)+                        7 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor DescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"DescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"field\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.FieldDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"extension\", fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 50}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.FieldDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"nested_type\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"enum_type\", fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.EnumDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"extension_range\", fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 42}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.DescriptorProto.ExtensionRange\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 58}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.MessageOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/DescriptorProto/ExtensionRange.hs view
@@ -1,15 +1,40 @@ module Text.DescriptorProtos.DescriptorProto.ExtensionRange-  (ExtensionRange(..))- where--import Text.ProtocolBuffers.Header--data ExtensionRange = ExtensionRange-    { start :: Maybe Int32-    , end :: Maybe Int32-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''ExtensionRange )--instance Default ExtensionRange where+       (ExtensionRange(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data ExtensionRange = ExtensionRange{start :: P'.Maybe P'.Int32,+                                     end :: P'.Maybe P'.Int32}+                    deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable ExtensionRange where+        mergeEmpty = ExtensionRange P'.mergeEmpty P'.mergeEmpty+        mergeAppend (ExtensionRange x'1 x'2) (ExtensionRange y'1 y'2)+          = ExtensionRange (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+ +instance P'.Default ExtensionRange where+        defaultValue+          = ExtensionRange (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire ExtensionRange where+        wireSize 11 (ExtensionRange x'1 x'2)+          = P'.lenSize (0 + P'.wireSizeOpt 1 5 x'1 + P'.wireSizeOpt 1 5 x'2)+        wirePut 11 self'@(ExtensionRange x'1 x'2)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 8 5 x'1+               P'.wirePutOpt 16 5 x'2+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{start = P'.Just new'Field})+                               (P'.wireGet 5)+                        2 -> P'.fmap (\ new'Field -> old'Self{end = P'.Just new'Field})+                               (P'.wireGet 5)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor ExtensionRange where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos.DescriptorProto\", baseName = \"ExtensionRange\"}, fields = fromList [FieldInfo {fieldName = \"start\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 5}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"end\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 5}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/EnumDescriptorProto.hs view
@@ -1,19 +1,58 @@ module Text.DescriptorProtos.EnumDescriptorProto-  (EnumDescriptorProto(..))- where--import Text.ProtocolBuffers.Header--import qualified Text.DescriptorProtos.EnumValueDescriptorProto as DescriptorProtos(EnumValueDescriptorProto)-import qualified Text.DescriptorProtos.EnumOptions as DescriptorProtos(EnumOptions)--data EnumDescriptorProto = EnumDescriptorProto-    { name :: Maybe ByteString-    , value :: Seq DescriptorProtos.EnumValueDescriptorProto-    , options :: Maybe DescriptorProtos.EnumOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''EnumDescriptorProto )--instance Default EnumDescriptorProto where+       (EnumDescriptorProto(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.EnumOptions+       as DescriptorProtos (EnumOptions)+import qualified Text.DescriptorProtos.EnumValueDescriptorProto+       as DescriptorProtos (EnumValueDescriptorProto)+ +data EnumDescriptorProto = EnumDescriptorProto{name ::+                                               P'.Maybe P'.ByteString,+                                               value ::+                                               P'.Seq DescriptorProtos.EnumValueDescriptorProto,+                                               options :: P'.Maybe DescriptorProtos.EnumOptions}+                         deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable EnumDescriptorProto where+        mergeEmpty+          = EnumDescriptorProto P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+        mergeAppend (EnumDescriptorProto x'1 x'2 x'3)+          (EnumDescriptorProto y'1 y'2 y'3)+          = EnumDescriptorProto (P'.mergeAppend x'1 y'1)+              (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+ +instance P'.Default EnumDescriptorProto where+        defaultValue+          = EnumDescriptorProto (P'.Just P'.defaultValue) (P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire EnumDescriptorProto where+        wireSize 11 (EnumDescriptorProto x'1 x'2 x'3)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeRep 1 11 x'2 ++                 P'.wireSizeOpt 1 11 x'3)+        wirePut 11 self'@(EnumDescriptorProto x'1 x'2 x'3)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutRep 18 11 x'2+               P'.wirePutOpt 26 11 x'3+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{value = P'.append (value old'Self) new'Field})+                               (P'.wireGet 11)+                        3 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor EnumDescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"EnumDescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"value\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.EnumValueDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.EnumOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/EnumOptions.hs view
@@ -1,12 +1,28 @@-module Text.DescriptorProtos.EnumOptions-  (EnumOptions(..))- where--import Text.ProtocolBuffers.Header--data EnumOptions = EnumOptions-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''EnumOptions )--instance Default EnumOptions where+module Text.DescriptorProtos.EnumOptions (EnumOptions(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data EnumOptions = EnumOptions{}+                 deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable EnumOptions where+        mergeEmpty = EnumOptions+        mergeAppend (EnumOptions) (EnumOptions) = EnumOptions+ +instance P'.Default EnumOptions where+        defaultValue = EnumOptions+ +instance P'.Wire EnumOptions where+        wireSize 11 (EnumOptions) = P'.lenSize (0)+        wirePut 11 self'@(EnumOptions)+          = do P'.putSize (P'.wireSize 11 self')+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor EnumOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"EnumOptions\"}, fields = fromList []}"
Text/DescriptorProtos/EnumValueDescriptorProto.hs view
@@ -1,17 +1,56 @@ module Text.DescriptorProtos.EnumValueDescriptorProto-  (EnumValueDescriptorProto(..))- where--import Text.ProtocolBuffers.Header-import qualified Text.DescriptorProtos.EnumValueOptions as DescriptorProtos(EnumValueOptions) --data EnumValueDescriptorProto = EnumValueDescriptorProto-    { name :: Maybe ByteString-    , number :: Maybe Int32-    , options :: Maybe DescriptorProtos.EnumValueOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''EnumValueDescriptorProto )--instance Default EnumValueDescriptorProto where+       (EnumValueDescriptorProto(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.EnumValueOptions+       as DescriptorProtos (EnumValueOptions)+ +data EnumValueDescriptorProto = EnumValueDescriptorProto{name ::+                                                         P'.Maybe P'.ByteString,+                                                         number :: P'.Maybe P'.Int32,+                                                         options ::+                                                         P'.Maybe DescriptorProtos.EnumValueOptions}+                              deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable EnumValueDescriptorProto where+        mergeEmpty+          = EnumValueDescriptorProto P'.mergeEmpty P'.mergeEmpty+              P'.mergeEmpty+        mergeAppend (EnumValueDescriptorProto x'1 x'2 x'3)+          (EnumValueDescriptorProto y'1 y'2 y'3)+          = EnumValueDescriptorProto (P'.mergeAppend x'1 y'1)+              (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+ +instance P'.Default EnumValueDescriptorProto where+        defaultValue+          = EnumValueDescriptorProto (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire EnumValueDescriptorProto where+        wireSize 11 (EnumValueDescriptorProto x'1 x'2 x'3)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeOpt 1 5 x'2 ++                 P'.wireSizeOpt 1 11 x'3)+        wirePut 11 self'@(EnumValueDescriptorProto x'1 x'2 x'3)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutOpt 16 5 x'2+               P'.wirePutOpt 26 11 x'3+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap (\ new'Field -> old'Self{number = P'.Just new'Field})+                               (P'.wireGet 5)+                        3 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor EnumValueDescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"EnumValueDescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"number\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 5}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.EnumValueOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/EnumValueOptions.hs view
@@ -1,14 +1,30 @@-{-# LANGUAGE TemplateHaskell #-}- module Text.DescriptorProtos.EnumValueOptions-  (EnumValueOptions(..))- where--import Text.ProtocolBuffers.Header--data EnumValueOptions = EnumValueOptions-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''EnumValueOptions )--instance Default EnumValueOptions where+       (EnumValueOptions(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data EnumValueOptions = EnumValueOptions{}+                      deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable EnumValueOptions where+        mergeEmpty = EnumValueOptions+        mergeAppend (EnumValueOptions) (EnumValueOptions)+          = EnumValueOptions+ +instance P'.Default EnumValueOptions where+        defaultValue = EnumValueOptions+ +instance P'.Wire EnumValueOptions where+        wireSize 11 (EnumValueOptions) = P'.lenSize (0)+        wirePut 11 self'@(EnumValueOptions)+          = do P'.putSize (P'.wireSize 11 self')+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor EnumValueOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"EnumValueOptions\"}, fields = fromList []}"
Text/DescriptorProtos/FieldDescriptorProto.hs view
@@ -1,24 +1,106 @@ module Text.DescriptorProtos.FieldDescriptorProto-  (FieldDescriptorProto(..))- where--import Text.ProtocolBuffers.Header-import qualified Text.DescriptorProtos.FieldDescriptorProto.Label as DescriptorProtos.FieldDescriptorProto(Label)-import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as DescriptorProtos.FieldDescriptorProto(Type)-import qualified Text.DescriptorProtos.FieldOptions as DescriptorProtos(FieldOptions)--data FieldDescriptorProto = FieldDescriptorProto-    { name :: Maybe ByteString-    , number :: Maybe Int32-    , label :: Maybe DescriptorProtos.FieldDescriptorProto.Label-    , type' :: Maybe DescriptorProtos.FieldDescriptorProto.Type-    , type_name :: Maybe ByteString-    , extendee :: Maybe ByteString-    , default_value :: Maybe ByteString-    , options :: Maybe DescriptorProtos.FieldOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''FieldDescriptorProto )--instance Default FieldDescriptorProto where+       (FieldDescriptorProto(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.FieldOptions+       as DescriptorProtos (FieldOptions)+import qualified Text.DescriptorProtos.FieldDescriptorProto.Label+       as DescriptorProtos.FieldDescriptorProto (Label)+import qualified Text.DescriptorProtos.FieldDescriptorProto.Type+       as DescriptorProtos.FieldDescriptorProto (Type)+ +data FieldDescriptorProto = FieldDescriptorProto{name ::+                                                 P'.Maybe P'.ByteString,+                                                 number :: P'.Maybe P'.Int32,+                                                 label ::+                                                 P'.Maybe+                                                   DescriptorProtos.FieldDescriptorProto.Label,+                                                 type' ::+                                                 P'.Maybe+                                                   DescriptorProtos.FieldDescriptorProto.Type,+                                                 type_name :: P'.Maybe P'.ByteString,+                                                 extendee :: P'.Maybe P'.ByteString,+                                                 default_value :: P'.Maybe P'.ByteString,+                                                 options :: P'.Maybe DescriptorProtos.FieldOptions}+                          deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable FieldDescriptorProto where+        mergeEmpty+          = FieldDescriptorProto P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+        mergeAppend (FieldDescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8)+          (FieldDescriptorProto y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8)+          = FieldDescriptorProto (P'.mergeAppend x'1 y'1)+              (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+              (P'.mergeAppend x'4 y'4)+              (P'.mergeAppend x'5 y'5)+              (P'.mergeAppend x'6 y'6)+              (P'.mergeAppend x'7 y'7)+              (P'.mergeAppend x'8 y'8)+ +instance P'.Default FieldDescriptorProto where+        defaultValue+          = FieldDescriptorProto (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire FieldDescriptorProto where+        wireSize 11 (FieldDescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeOpt 1 5 x'2 ++                 P'.wireSizeOpt 1 14 x'3+                 + P'.wireSizeOpt 1 14 x'4+                 + P'.wireSizeOpt 1 9 x'5+                 + P'.wireSizeOpt 1 9 x'6+                 + P'.wireSizeOpt 1 9 x'7+                 + P'.wireSizeOpt 1 11 x'8)+        wirePut 11+          self'@(FieldDescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutOpt 24 5 x'2+               P'.wirePutOpt 32 14 x'3+               P'.wirePutOpt 40 14 x'4+               P'.wirePutOpt 50 9 x'5+               P'.wirePutOpt 18 9 x'6+               P'.wirePutOpt 58 9 x'7+               P'.wirePutOpt 66 11 x'8+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        3 -> P'.fmap (\ new'Field -> old'Self{number = P'.Just new'Field})+                               (P'.wireGet 5)+                        4 -> P'.fmap (\ new'Field -> old'Self{label = P'.Just new'Field})+                               (P'.wireGet 14)+                        5 -> P'.fmap (\ new'Field -> old'Self{type' = P'.Just new'Field})+                               (P'.wireGet 14)+                        6 -> P'.fmap+                               (\ new'Field -> old'Self{type_name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap+                               (\ new'Field -> old'Self{extendee = P'.Just new'Field})+                               (P'.wireGet 9)+                        7 -> P'.fmap+                               (\ new'Field -> old'Self{default_value = P'.Just new'Field})+                               (P'.wireGet 9)+                        8 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor FieldDescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"FieldDescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"number\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 5}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"label\", fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 32}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 14}, typeName = Just \"DescriptorProtos.FieldDescriptorProto.Label\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"type'\", fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 14}, typeName = Just \"DescriptorProtos.FieldDescriptorProto.Type\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"type_name\", fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 50}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"extendee\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"default_value\", fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 58}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 8}, wireTag = WireTag {getWireTag = 66}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.FieldOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/FieldDescriptorProto/Label.hs view
@@ -1,12 +1,48 @@-module Text.DescriptorProtos.FieldDescriptorProto.Label-  (Label(..))- where--import Text.ProtocolBuffers.Header-+module Text.DescriptorProtos.FieldDescriptorProto.Label (Label(..))+       where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+  data Label = LABEL_OPTIONAL            | LABEL_REQUIRED            | LABEL_REPEATED-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeableEnum ''Label )+           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Label+ +instance P'.Bounded Label where+        minBound = LABEL_OPTIONAL+        maxBound = LABEL_REPEATED+ +instance P'.Default Label where+        defaultValue = LABEL_OPTIONAL+ +instance P'.Enum Label where+        fromEnum (LABEL_OPTIONAL) = 1+        fromEnum (LABEL_REQUIRED) = 2+        fromEnum (LABEL_REPEATED) = 3+        toEnum 1 = LABEL_OPTIONAL+        toEnum 2 = LABEL_REQUIRED+        toEnum 3 = LABEL_REPEATED+        succ (LABEL_OPTIONAL) = LABEL_REQUIRED+        succ (LABEL_REQUIRED) = LABEL_REPEATED+        pred (LABEL_REQUIRED) = LABEL_OPTIONAL+        pred (LABEL_REPEATED) = LABEL_REQUIRED+ +instance P'.Wire Label where+        wireSize 14 enum = P'.wireSize 14 (P'.fromEnum enum)+        wirePut 14 enum = P'.wirePut 14 (P'.fromEnum enum)+        wireGet 14 = P'.fmap P'.toEnum (P'.wireGet 14)+ +instance P'.ReflectEnum Label where+        reflectEnum+          = [(1, "LABEL_OPTIONAL", LABEL_OPTIONAL),+             (2, "LABEL_REQUIRED", LABEL_REQUIRED),+             (3, "LABEL_REPEATED", LABEL_REPEATED)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldDescriptorProto"+                 "Label")+              [(1, "LABEL_OPTIONAL"), (2, "LABEL_REQUIRED"),+               (3, "LABEL_REPEATED")]
Text/DescriptorProtos/FieldDescriptorProto/Type.hs view
@@ -1,28 +1,134 @@-module Text.DescriptorProtos.FieldDescriptorProto.Type-  (Type(..))- where--import Text.ProtocolBuffers.Header-+module Text.DescriptorProtos.FieldDescriptorProto.Type (Type(..))+       where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+  data Type = TYPE_DOUBLE           | TYPE_FLOAT-          | TYPE_INT64    -- inefficient for negative values+          | TYPE_INT64           | TYPE_UINT64-          | TYPE_INT32    -- inefficient for negative values+          | TYPE_INT32           | TYPE_FIXED64           | TYPE_FIXED32           | TYPE_BOOL           | TYPE_STRING-          | TYPE_GROUP      -- Tag-delimited aggregate.-          | TYPE_MESSAGE    -- Length-delimeted aggegate-            -- descriptor.proto "New in version 2"+          | TYPE_GROUP+          | TYPE_MESSAGE           | TYPE_BYTES           | TYPE_UINT32           | TYPE_ENUM           | TYPE_SFIXED32           | TYPE_SFIXED64-          | TYPE_SINT32 -- Uses ZipZag encoding-          | TYPE_SINT64 -- Uses ZipZag encoding-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeableEnum ''Type )+          | TYPE_SINT32+          | TYPE_SINT64+          deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Type+ +instance P'.Bounded Type where+        minBound = TYPE_DOUBLE+        maxBound = TYPE_SINT64+ +instance P'.Default Type where+        defaultValue = TYPE_DOUBLE+ +instance P'.Enum Type where+        fromEnum (TYPE_DOUBLE) = 1+        fromEnum (TYPE_FLOAT) = 2+        fromEnum (TYPE_INT64) = 3+        fromEnum (TYPE_UINT64) = 4+        fromEnum (TYPE_INT32) = 5+        fromEnum (TYPE_FIXED64) = 6+        fromEnum (TYPE_FIXED32) = 7+        fromEnum (TYPE_BOOL) = 8+        fromEnum (TYPE_STRING) = 9+        fromEnum (TYPE_GROUP) = 10+        fromEnum (TYPE_MESSAGE) = 11+        fromEnum (TYPE_BYTES) = 12+        fromEnum (TYPE_UINT32) = 13+        fromEnum (TYPE_ENUM) = 14+        fromEnum (TYPE_SFIXED32) = 15+        fromEnum (TYPE_SFIXED64) = 16+        fromEnum (TYPE_SINT32) = 17+        fromEnum (TYPE_SINT64) = 18+        toEnum 1 = TYPE_DOUBLE+        toEnum 2 = TYPE_FLOAT+        toEnum 3 = TYPE_INT64+        toEnum 4 = TYPE_UINT64+        toEnum 5 = TYPE_INT32+        toEnum 6 = TYPE_FIXED64+        toEnum 7 = TYPE_FIXED32+        toEnum 8 = TYPE_BOOL+        toEnum 9 = TYPE_STRING+        toEnum 10 = TYPE_GROUP+        toEnum 11 = TYPE_MESSAGE+        toEnum 12 = TYPE_BYTES+        toEnum 13 = TYPE_UINT32+        toEnum 14 = TYPE_ENUM+        toEnum 15 = TYPE_SFIXED32+        toEnum 16 = TYPE_SFIXED64+        toEnum 17 = TYPE_SINT32+        toEnum 18 = TYPE_SINT64+        succ (TYPE_DOUBLE) = TYPE_FLOAT+        succ (TYPE_FLOAT) = TYPE_INT64+        succ (TYPE_INT64) = TYPE_UINT64+        succ (TYPE_UINT64) = TYPE_INT32+        succ (TYPE_INT32) = TYPE_FIXED64+        succ (TYPE_FIXED64) = TYPE_FIXED32+        succ (TYPE_FIXED32) = TYPE_BOOL+        succ (TYPE_BOOL) = TYPE_STRING+        succ (TYPE_STRING) = TYPE_GROUP+        succ (TYPE_GROUP) = TYPE_MESSAGE+        succ (TYPE_MESSAGE) = TYPE_BYTES+        succ (TYPE_BYTES) = TYPE_UINT32+        succ (TYPE_UINT32) = TYPE_ENUM+        succ (TYPE_ENUM) = TYPE_SFIXED32+        succ (TYPE_SFIXED32) = TYPE_SFIXED64+        succ (TYPE_SFIXED64) = TYPE_SINT32+        succ (TYPE_SINT32) = TYPE_SINT64+        pred (TYPE_FLOAT) = TYPE_DOUBLE+        pred (TYPE_INT64) = TYPE_FLOAT+        pred (TYPE_UINT64) = TYPE_INT64+        pred (TYPE_INT32) = TYPE_UINT64+        pred (TYPE_FIXED64) = TYPE_INT32+        pred (TYPE_FIXED32) = TYPE_FIXED64+        pred (TYPE_BOOL) = TYPE_FIXED32+        pred (TYPE_STRING) = TYPE_BOOL+        pred (TYPE_GROUP) = TYPE_STRING+        pred (TYPE_MESSAGE) = TYPE_GROUP+        pred (TYPE_BYTES) = TYPE_MESSAGE+        pred (TYPE_UINT32) = TYPE_BYTES+        pred (TYPE_ENUM) = TYPE_UINT32+        pred (TYPE_SFIXED32) = TYPE_ENUM+        pred (TYPE_SFIXED64) = TYPE_SFIXED32+        pred (TYPE_SINT32) = TYPE_SFIXED64+        pred (TYPE_SINT64) = TYPE_SINT32+ +instance P'.Wire Type where+        wireSize 14 enum = P'.wireSize 14 (P'.fromEnum enum)+        wirePut 14 enum = P'.wirePut 14 (P'.fromEnum enum)+        wireGet 14 = P'.fmap P'.toEnum (P'.wireGet 14)+ +instance P'.ReflectEnum Type where+        reflectEnum+          = [(1, "TYPE_DOUBLE", TYPE_DOUBLE), (2, "TYPE_FLOAT", TYPE_FLOAT),+             (3, "TYPE_INT64", TYPE_INT64), (4, "TYPE_UINT64", TYPE_UINT64),+             (5, "TYPE_INT32", TYPE_INT32), (6, "TYPE_FIXED64", TYPE_FIXED64),+             (7, "TYPE_FIXED32", TYPE_FIXED32), (8, "TYPE_BOOL", TYPE_BOOL),+             (9, "TYPE_STRING", TYPE_STRING), (10, "TYPE_GROUP", TYPE_GROUP),+             (11, "TYPE_MESSAGE", TYPE_MESSAGE), (12, "TYPE_BYTES", TYPE_BYTES),+             (13, "TYPE_UINT32", TYPE_UINT32), (14, "TYPE_ENUM", TYPE_ENUM),+             (15, "TYPE_SFIXED32", TYPE_SFIXED32),+             (16, "TYPE_SFIXED64", TYPE_SFIXED64),+             (17, "TYPE_SINT32", TYPE_SINT32), (18, "TYPE_SINT64", TYPE_SINT64)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldDescriptorProto"+                 "Type")+              [(1, "TYPE_DOUBLE"), (2, "TYPE_FLOAT"), (3, "TYPE_INT64"),+               (4, "TYPE_UINT64"), (5, "TYPE_INT32"), (6, "TYPE_FIXED64"),+               (7, "TYPE_FIXED32"), (8, "TYPE_BOOL"), (9, "TYPE_STRING"),+               (10, "TYPE_GROUP"), (11, "TYPE_MESSAGE"), (12, "TYPE_BYTES"),+               (13, "TYPE_UINT32"), (14, "TYPE_ENUM"), (15, "TYPE_SFIXED32"),+               (16, "TYPE_SFIXED64"), (17, "TYPE_SINT32"), (18, "TYPE_SINT64")]
Text/DescriptorProtos/FieldOptions.hs view
@@ -1,18 +1,42 @@-module Text.DescriptorProtos.FieldOptions-  (FieldOptions(..))- where--import Text.ProtocolBuffers.Header--import qualified Text.DescriptorProtos.FieldOptions.CType as DescriptorProtos.FieldOptions(CType)--data FieldOptions = FieldOptions-    { ctype :: Maybe DescriptorProtos.FieldOptions.CType-    , experimental_map_key :: Maybe ByteString-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''FieldOptions )--instance Default FieldOptions where-+module Text.DescriptorProtos.FieldOptions (FieldOptions(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.FieldOptions.CType+       as DescriptorProtos.FieldOptions (CType)+ +data FieldOptions = FieldOptions{ctype ::+                                 P'.Maybe DescriptorProtos.FieldOptions.CType,+                                 experimental_map_key :: P'.Maybe P'.ByteString}+                  deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable FieldOptions where+        mergeEmpty = FieldOptions P'.mergeEmpty P'.mergeEmpty+        mergeAppend (FieldOptions x'1 x'2) (FieldOptions y'1 y'2)+          = FieldOptions (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+ +instance P'.Default FieldOptions where+        defaultValue+          = FieldOptions (P'.Just P'.defaultValue) (P'.Just P'.defaultValue)+ +instance P'.Wire FieldOptions where+        wireSize 11 (FieldOptions x'1 x'2)+          = P'.lenSize (0 + P'.wireSizeOpt 1 14 x'1 + P'.wireSizeOpt 1 9 x'2)+        wirePut 11 self'@(FieldOptions x'1 x'2)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 8 14 x'1+               P'.wirePutOpt 74 9 x'2+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{ctype = P'.Just new'Field})+                               (P'.wireGet 14)+                        9 -> P'.fmap+                               (\ new'Field -> old'Self{experimental_map_key = P'.Just new'Field})+                               (P'.wireGet 9)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor FieldOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"FieldOptions\"}, fields = fromList [FieldInfo {fieldName = \"ctype\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 14}, typeName = Just \"DescriptorProtos.FieldOptions.CType\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"experimental_map_key\", fieldNumber = FieldId {getFieldId = 9}, wireTag = WireTag {getWireTag = 74}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/FieldOptions/CType.hs view
@@ -1,11 +1,38 @@-module Text.DescriptorProtos.FieldOptions.CType-  (CType(..))- where--import Text.ProtocolBuffers.Header--data CType = CORD | STRING_PIECE-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeableEnum ''CType )-+module Text.DescriptorProtos.FieldOptions.CType (CType(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data CType = CORD+           | STRING_PIECE+           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable CType+ +instance P'.Bounded CType where+        minBound = CORD+        maxBound = STRING_PIECE+ +instance P'.Default CType where+        defaultValue = CORD+ +instance P'.Enum CType where+        fromEnum (CORD) = 1+        fromEnum (STRING_PIECE) = 2+        toEnum 1 = CORD+        toEnum 2 = STRING_PIECE+        succ (CORD) = STRING_PIECE+        pred (STRING_PIECE) = CORD+ +instance P'.Wire CType where+        wireSize 14 enum = P'.wireSize 14 (P'.fromEnum enum)+        wirePut 14 enum = P'.wirePut 14 (P'.fromEnum enum)+        wireGet 14 = P'.fmap P'.toEnum (P'.wireGet 14)+ +instance P'.ReflectEnum CType where+        reflectEnum+          = [(1, "CORD", CORD), (2, "STRING_PIECE", STRING_PIECE)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldOptions" "CType")+              [(1, "CORD"), (2, "STRING_PIECE")]
Text/DescriptorProtos/FileDescriptorProto.hs view
@@ -1,26 +1,118 @@ module Text.DescriptorProtos.FileDescriptorProto-  (FileDescriptorProto(..))- where--import Text.ProtocolBuffers.Header-import qualified Text.DescriptorProtos.DescriptorProto as DescriptorProtos(DescriptorProto) -import qualified Text.DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) -import qualified Text.DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) -import qualified Text.DescriptorProtos.FileOptions as DescriptorProtos(FileOptions)-import qualified Text.DescriptorProtos.ServiceDescriptorProto as DescriptorProtos(ServiceDescriptorProto) --data FileDescriptorProto = FileDescriptorProto-    { name :: Maybe ByteString-    , package :: Maybe ByteString-    , dependency :: Seq ByteString-    , message_type :: Seq DescriptorProtos.DescriptorProto-    , enum_type :: Seq DescriptorProtos.EnumDescriptorProto-    , service :: Seq DescriptorProtos.ServiceDescriptorProto-    , extension :: Seq DescriptorProtos.FieldDescriptorProto-    , options :: Maybe DescriptorProtos.FileOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''FileDescriptorProto )--instance Default FileDescriptorProto where+       (FileDescriptorProto(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.DescriptorProto+       as DescriptorProtos (DescriptorProto)+import qualified Text.DescriptorProtos.EnumDescriptorProto+       as DescriptorProtos (EnumDescriptorProto)+import qualified Text.DescriptorProtos.FieldDescriptorProto+       as DescriptorProtos (FieldDescriptorProto)+import qualified Text.DescriptorProtos.FileOptions+       as DescriptorProtos (FileOptions)+import qualified Text.DescriptorProtos.ServiceDescriptorProto+       as DescriptorProtos (ServiceDescriptorProto)+ +data FileDescriptorProto = FileDescriptorProto{name ::+                                               P'.Maybe P'.ByteString,+                                               package :: P'.Maybe P'.ByteString,+                                               dependency :: P'.Seq P'.ByteString,+                                               message_type ::+                                               P'.Seq DescriptorProtos.DescriptorProto,+                                               enum_type ::+                                               P'.Seq DescriptorProtos.EnumDescriptorProto,+                                               service ::+                                               P'.Seq DescriptorProtos.ServiceDescriptorProto,+                                               extension ::+                                               P'.Seq DescriptorProtos.FieldDescriptorProto,+                                               options :: P'.Maybe DescriptorProtos.FileOptions}+                         deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable FileDescriptorProto where+        mergeEmpty+          = FileDescriptorProto P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+              P'.mergeEmpty+        mergeAppend (FileDescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8)+          (FileDescriptorProto y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8)+          = FileDescriptorProto (P'.mergeAppend x'1 y'1)+              (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+              (P'.mergeAppend x'4 y'4)+              (P'.mergeAppend x'5 y'5)+              (P'.mergeAppend x'6 y'6)+              (P'.mergeAppend x'7 y'7)+              (P'.mergeAppend x'8 y'8)+ +instance P'.Default FileDescriptorProto where+        defaultValue+          = FileDescriptorProto (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire FileDescriptorProto where+        wireSize 11 (FileDescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeOpt 1 9 x'2 ++                 P'.wireSizeRep 1 9 x'3+                 + P'.wireSizeRep 1 11 x'4+                 + P'.wireSizeRep 1 11 x'5+                 + P'.wireSizeRep 1 11 x'6+                 + P'.wireSizeRep 1 11 x'7+                 + P'.wireSizeOpt 1 11 x'8)+        wirePut 11+          self'@(FileDescriptorProto x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutOpt 18 9 x'2+               P'.wirePutRep 26 9 x'3+               P'.wirePutRep 34 11 x'4+               P'.wirePutRep 42 11 x'5+               P'.wirePutRep 50 11 x'6+               P'.wirePutRep 58 11 x'7+               P'.wirePutOpt 66 11 x'8+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap (\ new'Field -> old'Self{package = P'.Just new'Field})+                               (P'.wireGet 9)+                        3 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{dependency = P'.append (dependency old'Self) new'Field})+                               (P'.wireGet 9)+                        4 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{message_type =+                                             P'.append (message_type old'Self) new'Field})+                               (P'.wireGet 11)+                        5 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{enum_type = P'.append (enum_type old'Self) new'Field})+                               (P'.wireGet 11)+                        6 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{service = P'.append (service old'Self) new'Field})+                               (P'.wireGet 11)+                        7 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{extension = P'.append (extension old'Self) new'Field})+                               (P'.wireGet 11)+                        8 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor FileDescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"FileDescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"package\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"dependency\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"message_type\", fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.DescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"enum_type\", fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 42}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.EnumDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"service\", fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 50}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.ServiceDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"extension\", fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 58}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.FieldDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 8}, wireTag = WireTag {getWireTag = 66}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.FileOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/FileOptions.hs view
@@ -1,23 +1,63 @@-module Text.DescriptorProtos.FileOptions-  (FileOptions(..))- where--import Text.ProtocolBuffers.Header-import qualified Text.DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions(OptimizeMode)-import qualified Text.DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions.OptimizeMode(OptimizeMode(..))--data FileOptions = FileOptions-    { java_package :: Maybe ByteString-    , java_outer_classname :: Maybe ByteString-    , java_multiple_files :: Maybe Bool-    , optimize_for :: Maybe DescriptorProtos.FileOptions.OptimizeMode-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''FileOptions )--instance Default FileOptions where-  defaultValue = mergeEmpty-    { java_multiple_files = Just False-    , optimize_for = Just DescriptorProtos.FileOptions.OptimizeMode.CODE_SIZE-    }+module Text.DescriptorProtos.FileOptions (FileOptions(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.FileOptions.OptimizeMode+       as DescriptorProtos.FileOptions (OptimizeMode)+ +data FileOptions = FileOptions{java_package ::+                               P'.Maybe P'.ByteString,+                               java_outer_classname :: P'.Maybe P'.ByteString,+                               java_multiple_files :: P'.Maybe P'.Bool,+                               optimize_for :: P'.Maybe DescriptorProtos.FileOptions.OptimizeMode}+                 deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable FileOptions where+        mergeEmpty+          = FileOptions P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+              P'.mergeEmpty+        mergeAppend (FileOptions x'1 x'2 x'3 x'4)+          (FileOptions y'1 y'2 y'3 y'4)+          = FileOptions (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+              (P'.mergeAppend x'4 y'4)+ +instance P'.Default FileOptions where+        defaultValue+          = FileOptions (P'.Just P'.defaultValue) (P'.Just P'.defaultValue)+              (P'.Just (P'.False))+              (P'.Just P'.defaultValue)+ +instance P'.Wire FileOptions where+        wireSize 11 (FileOptions x'1 x'2 x'3 x'4)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeOpt 1 9 x'2 ++                 P'.wireSizeOpt 1 8 x'3+                 + P'.wireSizeOpt 1 14 x'4)+        wirePut 11 self'@(FileOptions x'1 x'2 x'3 x'4)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutOpt 66 9 x'2+               P'.wirePutOpt 80 8 x'3+               P'.wirePutOpt 72 14 x'4+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap+                               (\ new'Field -> old'Self{java_package = P'.Just new'Field})+                               (P'.wireGet 9)+                        8 -> P'.fmap+                               (\ new'Field -> old'Self{java_outer_classname = P'.Just new'Field})+                               (P'.wireGet 9)+                        10 -> P'.fmap+                                (\ new'Field -> old'Self{java_multiple_files = P'.Just new'Field})+                                (P'.wireGet 8)+                        9 -> P'.fmap+                               (\ new'Field -> old'Self{optimize_for = P'.Just new'Field})+                               (P'.wireGet 14)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor FileOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"FileOptions\"}, fields = fromList [FieldInfo {fieldName = \"java_package\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"java_outer_classname\", fieldNumber = FieldId {getFieldId = 8}, wireTag = WireTag {getWireTag = 66}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"java_multiple_files\", fieldNumber = FieldId {getFieldId = 10}, wireTag = WireTag {getWireTag = 80}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 8}, typeName = Nothing, hsRawDefault = Just (Chunk \"false\" Empty), hsDefault = Just (HsDef'Bool False)},FieldInfo {fieldName = \"optimize_for\", fieldNumber = FieldId {getFieldId = 9}, wireTag = WireTag {getWireTag = 72}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 14}, typeName = Just \"DescriptorProtos.FileOptions.OptimizeMode\", hsRawDefault = Just (Chunk \"CODE_SIZE\" Empty), hsDefault = Nothing}]}"
Text/DescriptorProtos/FileOptions/OptimizeMode.hs view
@@ -1,31 +1,38 @@ module Text.DescriptorProtos.FileOptions.OptimizeMode-  (OptimizeMode(..))- where--import Data.Monoid-import Text.ProtocolBuffers.Header--data OptimizeMode = SPEED | CODE_SIZE-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeableEnum ''OptimizeMode )--err'Name :: String-err'Name = "DescriptorProtos.FileOptions.OptimizeMode"--err' :: String -> b-err' a = error (err'Name ++ " : " ++ show a)--instance Enum OptimizeMode where-  fromEnum SPEED = 1-  fromEnum CODE_SIZE = 2--  toEnum 1 = SPEED-  toEnum 2 = CODE_SIZE-  toEnum x = err' ("toEnum failed on value "++show x)--  succ SPEED = CODE_SIZE-  succ CODE_SIZE = err' ("succ failed on value "++show CODE_SIZE)--  pred SPEED = err' ("pred failed on value "++show SPEED)-  pred CODE_SIZE = SPEED+       (OptimizeMode(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data OptimizeMode = SPEED+                  | CODE_SIZE+                  deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable OptimizeMode+ +instance P'.Bounded OptimizeMode where+        minBound = SPEED+        maxBound = CODE_SIZE+ +instance P'.Default OptimizeMode where+        defaultValue = SPEED+ +instance P'.Enum OptimizeMode where+        fromEnum (SPEED) = 1+        fromEnum (CODE_SIZE) = 2+        toEnum 1 = SPEED+        toEnum 2 = CODE_SIZE+        succ (SPEED) = CODE_SIZE+        pred (CODE_SIZE) = SPEED+ +instance P'.Wire OptimizeMode where+        wireSize 14 enum = P'.wireSize 14 (P'.fromEnum enum)+        wirePut 14 enum = P'.wirePut 14 (P'.fromEnum enum)+        wireGet 14 = P'.fmap P'.toEnum (P'.wireGet 14)+ +instance P'.ReflectEnum OptimizeMode where+        reflectEnum = [(1, "SPEED", SPEED), (2, "CODE_SIZE", CODE_SIZE)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FileOptions" "OptimizeMode")+              [(1, "SPEED"), (2, "CODE_SIZE")]
Text/DescriptorProtos/MessageOptions.hs view
@@ -1,17 +1,37 @@-module Text.DescriptorProtos.MessageOptions-  (MessageOptions(..))- where--import Text.ProtocolBuffers.Header--data MessageOptions = MessageOptions-    { message_set_wire_format :: Maybe Bool-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''MessageOptions )--instance Default MessageOptions where-  defaultValue = mergeEmpty-    { message_set_wire_format = Just False-    }+module Text.DescriptorProtos.MessageOptions (MessageOptions(..))+       where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data MessageOptions = MessageOptions{message_set_wire_format ::+                                     P'.Maybe P'.Bool}+                    deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable MessageOptions where+        mergeEmpty = MessageOptions P'.mergeEmpty+        mergeAppend (MessageOptions x'1) (MessageOptions y'1)+          = MessageOptions (P'.mergeAppend x'1 y'1)+ +instance P'.Default MessageOptions where+        defaultValue = MessageOptions (P'.Just (P'.False))+ +instance P'.Wire MessageOptions where+        wireSize 11 (MessageOptions x'1)+          = P'.lenSize (0 + P'.wireSizeOpt 1 8 x'1)+        wirePut 11 self'@(MessageOptions x'1)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 8 8 x'1+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{message_set_wire_format = P'.Just new'Field})+                               (P'.wireGet 8)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor MessageOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"MessageOptions\"}, fields = fromList [FieldInfo {fieldName = \"message_set_wire_format\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 8}, typeName = Nothing, hsRawDefault = Just (Chunk \"false\" Empty), hsDefault = Just (HsDef'Bool False)}]}"
Text/DescriptorProtos/MethodDescriptorProto.hs view
@@ -1,18 +1,65 @@ module Text.DescriptorProtos.MethodDescriptorProto-  (MethodDescriptorProto(..))- where--import Text.ProtocolBuffers.Header-import qualified Text.DescriptorProtos.MethodOptions as DescriptorProtos(MethodOptions)--data MethodDescriptorProto = MethodDescriptorProto-    { name :: Maybe ByteString-    , input_type :: Maybe ByteString-    , output_type :: Maybe ByteString-    , options :: Maybe DescriptorProtos.MethodOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''MethodDescriptorProto )--instance Default MethodDescriptorProto where+       (MethodDescriptorProto(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.MethodOptions+       as DescriptorProtos (MethodOptions)+ +data MethodDescriptorProto = MethodDescriptorProto{name ::+                                                   P'.Maybe P'.ByteString,+                                                   input_type :: P'.Maybe P'.ByteString,+                                                   output_type :: P'.Maybe P'.ByteString,+                                                   options ::+                                                   P'.Maybe DescriptorProtos.MethodOptions}+                           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable MethodDescriptorProto where+        mergeEmpty+          = MethodDescriptorProto P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+              P'.mergeEmpty+        mergeAppend (MethodDescriptorProto x'1 x'2 x'3 x'4)+          (MethodDescriptorProto y'1 y'2 y'3 y'4)+          = MethodDescriptorProto (P'.mergeAppend x'1 y'1)+              (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+              (P'.mergeAppend x'4 y'4)+ +instance P'.Default MethodDescriptorProto where+        defaultValue+          = MethodDescriptorProto (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire MethodDescriptorProto where+        wireSize 11 (MethodDescriptorProto x'1 x'2 x'3 x'4)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeOpt 1 9 x'2 ++                 P'.wireSizeOpt 1 9 x'3+                 + P'.wireSizeOpt 1 11 x'4)+        wirePut 11 self'@(MethodDescriptorProto x'1 x'2 x'3 x'4)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutOpt 18 9 x'2+               P'.wirePutOpt 26 9 x'3+               P'.wirePutOpt 34 11 x'4+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap+                               (\ new'Field -> old'Self{input_type = P'.Just new'Field})+                               (P'.wireGet 9)+                        3 -> P'.fmap+                               (\ new'Field -> old'Self{output_type = P'.Just new'Field})+                               (P'.wireGet 9)+                        4 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor MethodDescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"MethodDescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"input_type\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"output_type\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.MethodOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/MethodOptions.hs view
@@ -1,12 +1,29 @@-module Text.DescriptorProtos.MethodOptions-  (MethodOptions(..))- where--import Text.ProtocolBuffers.Header--data MethodOptions = MethodOptions-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''MethodOptions )--instance Default MethodOptions where+module Text.DescriptorProtos.MethodOptions (MethodOptions(..))+       where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data MethodOptions = MethodOptions{}+                   deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable MethodOptions where+        mergeEmpty = MethodOptions+        mergeAppend (MethodOptions) (MethodOptions) = MethodOptions+ +instance P'.Default MethodOptions where+        defaultValue = MethodOptions+ +instance P'.Wire MethodOptions where+        wireSize 11 (MethodOptions) = P'.lenSize (0)+        wirePut 11 self'@(MethodOptions)+          = do P'.putSize (P'.wireSize 11 self')+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor MethodOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"MethodOptions\"}, fields = fromList []}"
Text/DescriptorProtos/ServiceDescriptorProto.hs view
@@ -1,19 +1,60 @@ module Text.DescriptorProtos.ServiceDescriptorProto-  (ServiceDescriptorProto(..))- where--import Text.ProtocolBuffers.Header--import qualified Text.DescriptorProtos.MethodDescriptorProto as DescriptorProtos(MethodDescriptorProto)-import qualified Text.DescriptorProtos.ServiceOptions as DescriptorProtos(ServiceOptions)--data ServiceDescriptorProto = ServiceDescriptorProto-    { name :: Maybe ByteString-    , method :: Seq DescriptorProtos.MethodDescriptorProto-    , options :: Maybe DescriptorProtos.ServiceOptions-    }-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''ServiceDescriptorProto )--instance Default ServiceDescriptorProto where+       (ServiceDescriptorProto(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.MethodDescriptorProto+       as DescriptorProtos (MethodDescriptorProto)+import qualified Text.DescriptorProtos.ServiceOptions+       as DescriptorProtos (ServiceOptions)+ +data ServiceDescriptorProto = ServiceDescriptorProto{name ::+                                                     P'.Maybe P'.ByteString,+                                                     method ::+                                                     P'.Seq DescriptorProtos.MethodDescriptorProto,+                                                     options ::+                                                     P'.Maybe DescriptorProtos.ServiceOptions}+                            deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable ServiceDescriptorProto where+        mergeEmpty+          = ServiceDescriptorProto P'.mergeEmpty P'.mergeEmpty P'.mergeEmpty+        mergeAppend (ServiceDescriptorProto x'1 x'2 x'3)+          (ServiceDescriptorProto y'1 y'2 y'3)+          = ServiceDescriptorProto (P'.mergeAppend x'1 y'1)+              (P'.mergeAppend x'2 y'2)+              (P'.mergeAppend x'3 y'3)+ +instance P'.Default ServiceDescriptorProto where+        defaultValue+          = ServiceDescriptorProto (P'.Just P'.defaultValue)+              (P'.defaultValue)+              (P'.Just P'.defaultValue)+ +instance P'.Wire ServiceDescriptorProto where+        wireSize 11 (ServiceDescriptorProto x'1 x'2 x'3)+          = P'.lenSize+              (0 + P'.wireSizeOpt 1 9 x'1 + P'.wireSizeRep 1 11 x'2 ++                 P'.wireSizeOpt 1 11 x'3)+        wirePut 11 self'@(ServiceDescriptorProto x'1 x'2 x'3)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 10 9 x'1+               P'.wirePutRep 18 11 x'2+               P'.wirePutOpt 26 11 x'3+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        1 -> P'.fmap (\ new'Field -> old'Self{name = P'.Just new'Field})+                               (P'.wireGet 9)+                        2 -> P'.fmap+                               (\ new'Field ->+                                  old'Self{method = P'.append (method old'Self) new'Field})+                               (P'.wireGet 11)+                        3 -> P'.fmap (\ new'Field -> old'Self{options = P'.Just new'Field})+                               (P'.wireGet 11)+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor ServiceDescriptorProto where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"ServiceDescriptorProto\"}, fields = fromList [FieldInfo {fieldName = \"name\", fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"method\", fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, wireTagLength = 1, isRequired = False, canRepeat = True, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.MethodDescriptorProto\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"options\", fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 11}, typeName = Just \"DescriptorProtos.ServiceOptions\", hsRawDefault = Nothing, hsDefault = Nothing}]}"
Text/DescriptorProtos/ServiceOptions.hs view
@@ -1,12 +1,29 @@-module Text.DescriptorProtos.ServiceOptions-  (ServiceOptions(..))- where--import Text.ProtocolBuffers.Header--data ServiceOptions = ServiceOptions-  deriving (Show,Eq,Ord,Typeable)--$( makeMergeable ''ServiceOptions )--instance Default ServiceOptions where+module Text.DescriptorProtos.ServiceOptions (ServiceOptions(..))+       where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data ServiceOptions = ServiceOptions{}+                    deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable ServiceOptions where+        mergeEmpty = ServiceOptions+        mergeAppend (ServiceOptions) (ServiceOptions) = ServiceOptions+ +instance P'.Default ServiceOptions where+        defaultValue = ServiceOptions+ +instance P'.Wire ServiceOptions where+        wireSize 11 (ServiceOptions) = P'.lenSize (0)+        wirePut 11 self'@(ServiceOptions)+          = do P'.putSize (P'.wireSize 11 self')+        wireGet 11 = P'.getMessage update'Self+          where update'Self field'Number old'Self+                  = case field'Number of+                        _ -> P'.unknownField field'Number+ +instance P'.ReflectDescriptor ServiceOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"ServiceOptions\"}, fields = fromList []}"
+ Text/Hand-DescriptorProtos/DescriptorProto.hs view
@@ -0,0 +1,25 @@+module Text.DescriptorProtos.DescriptorProto+  (DescriptorProto(..))+ where++import Text.ProtocolBuffers.Header+import qualified Text.DescriptorProtos.FileOptions as DescriptorProtos(FileOptions)+import qualified Text.DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) +import qualified Text.DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) +import qualified Text.DescriptorProtos.MessageOptions as DescriptorProtos(MessageOptions)+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as DescriptorProtos.DescriptorProto(ExtensionRange)++data DescriptorProto = DescriptorProto+    { name :: Maybe ByteString+    , field :: Seq DescriptorProtos.FieldDescriptorProto+    , extension :: Seq DescriptorProtos.FieldDescriptorProto+    , nested_type :: Seq DescriptorProto+    , enum_type :: Seq DescriptorProtos.EnumDescriptorProto+    , extension_range :: Seq DescriptorProtos.DescriptorProto.ExtensionRange+    , options :: Maybe DescriptorProtos.MessageOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''DescriptorProto )++instance Default DescriptorProto where
+ Text/Hand-DescriptorProtos/DescriptorProto/ExtensionRange.hs view
@@ -0,0 +1,15 @@+module Text.DescriptorProtos.DescriptorProto.ExtensionRange+  (ExtensionRange(..))+ where++import Text.ProtocolBuffers.Header++data ExtensionRange = ExtensionRange+    { start :: Maybe Int32+    , end :: Maybe Int32+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''ExtensionRange )++instance Default ExtensionRange where
+ Text/Hand-DescriptorProtos/EnumDescriptorProto.hs view
@@ -0,0 +1,19 @@+module Text.DescriptorProtos.EnumDescriptorProto+  (EnumDescriptorProto(..))+ where++import Text.ProtocolBuffers.Header++import qualified Text.DescriptorProtos.EnumValueDescriptorProto as DescriptorProtos(EnumValueDescriptorProto)+import qualified Text.DescriptorProtos.EnumOptions as DescriptorProtos(EnumOptions)++data EnumDescriptorProto = EnumDescriptorProto+    { name :: Maybe ByteString+    , value :: Seq DescriptorProtos.EnumValueDescriptorProto+    , options :: Maybe DescriptorProtos.EnumOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''EnumDescriptorProto )++instance Default EnumDescriptorProto where
+ Text/Hand-DescriptorProtos/EnumOptions.hs view
@@ -0,0 +1,12 @@+module Text.DescriptorProtos.EnumOptions+  (EnumOptions(..))+ where++import Text.ProtocolBuffers.Header++data EnumOptions = EnumOptions+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''EnumOptions )++instance Default EnumOptions where
+ Text/Hand-DescriptorProtos/EnumValueDescriptorProto.hs view
@@ -0,0 +1,17 @@+module Text.DescriptorProtos.EnumValueDescriptorProto+  (EnumValueDescriptorProto(..))+ where++import Text.ProtocolBuffers.Header+import qualified Text.DescriptorProtos.EnumValueOptions as DescriptorProtos(EnumValueOptions) ++data EnumValueDescriptorProto = EnumValueDescriptorProto+    { name :: Maybe ByteString+    , number :: Maybe Int32+    , options :: Maybe DescriptorProtos.EnumValueOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''EnumValueDescriptorProto )++instance Default EnumValueDescriptorProto where
+ Text/Hand-DescriptorProtos/EnumValueOptions.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}++module Text.DescriptorProtos.EnumValueOptions+  (EnumValueOptions(..))+ where++import Text.ProtocolBuffers.Header++data EnumValueOptions = EnumValueOptions+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''EnumValueOptions )++instance Default EnumValueOptions where
+ Text/Hand-DescriptorProtos/FieldDescriptorProto.hs view
@@ -0,0 +1,24 @@+module Text.DescriptorProtos.FieldDescriptorProto+  (FieldDescriptorProto(..))+ where++import Text.ProtocolBuffers.Header+import qualified Text.DescriptorProtos.FieldDescriptorProto.Label as DescriptorProtos.FieldDescriptorProto(Label)+import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as DescriptorProtos.FieldDescriptorProto(Type)+import qualified Text.DescriptorProtos.FieldOptions as DescriptorProtos(FieldOptions)++data FieldDescriptorProto = FieldDescriptorProto+    { name :: Maybe ByteString+    , number :: Maybe Int32+    , label :: Maybe DescriptorProtos.FieldDescriptorProto.Label+    , type' :: Maybe DescriptorProtos.FieldDescriptorProto.Type+    , type_name :: Maybe ByteString+    , extendee :: Maybe ByteString+    , default_value :: Maybe ByteString+    , options :: Maybe DescriptorProtos.FieldOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''FieldDescriptorProto )++instance Default FieldDescriptorProto where
+ Text/Hand-DescriptorProtos/FieldDescriptorProto/Label.hs view
@@ -0,0 +1,188 @@+module Text.DescriptorProtos.FieldDescriptorProto.Label (Label(..))+       where+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data Label = LABEL_OPTIONAL+           | LABEL_REQUIRED+           | LABEL_REPEATED+           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Label+ +instance P'.Bounded Label where+        minBound = LABEL_OPTIONAL+        maxBound = LABEL_REPEATED+ +instance P'.Default Label where+        defaultValue = LABEL_OPTIONAL+ +instance P'.Enum Label where+        fromEnum (LABEL_OPTIONAL) = 1+        fromEnum (LABEL_REQUIRED) = 2+        fromEnum (LABEL_REPEATED) = 3+        toEnum 1 = LABEL_OPTIONAL+        toEnum 2 = LABEL_REQUIRED+        toEnum 3 = LABEL_REPEATED+        succ (LABEL_OPTIONAL) = LABEL_REQUIRED+        succ (LABEL_REQUIRED) = LABEL_REPEATED+        pred (LABEL_REQUIRED) = LABEL_OPTIONAL+        pred (LABEL_REPEATED) = LABEL_REQUIRED+ +instance P'.Wire Label where+        wireSize 14 enum = P'.wireSize 14 (P'.fromEnum enum)+        wirePut 14 enum = P'.wirePut 14 (P'.fromEnum enum)+        wireGet 14 = P'.fmap P'.toEnum (P'.wireGet 14)+ +instance P'.ReflectEnum Label where+        reflectEnum+          = [(1, "LABEL_OPTIONAL", LABEL_OPTIONAL),+             (2, "LABEL_REQUIRED", LABEL_REQUIRED),+             (3, "LABEL_REPEATED", LABEL_REPEATED)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldDescriptorProto"+                 "Label")+              [(1, "LABEL_OPTIONAL"), (2, "LABEL_REQUIRED"),+               (3, "LABEL_REPEATED")]+{-+module Text.DescriptorProtos.FieldDescriptorProto.Label (Label(..))+       where+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data Label = LABEL_OPTIONAL+           | LABEL_REQUIRED+           | LABEL_REPEATED+           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Label+ +instance P'.Bounded Label where+        minBound = LABEL_OPTIONAL+        maxBound = LABEL_REPEATED+ +instance P'.Default Label where+        defaultValue = LABEL_OPTIONAL+ +instance P'.Enum Label where+        fromEnum (LABEL_OPTIONAL) = 1+        fromEnum (LABEL_REQUIRED) = 2+        fromEnum (LABEL_REPEATED) = 3+        toEnum 1 = LABEL_OPTIONAL+        toEnum 2 = LABEL_REQUIRED+        toEnum 3 = LABEL_REPEATED+        succ (LABEL_OPTIONAL) = LABEL_REQUIRED+        succ (LABEL_REQUIRED) = LABEL_REPEATED+        pred (LABEL_REQUIRED) = LABEL_OPTIONAL+        pred (LABEL_REPEATED) = LABEL_REQUIRED+ +instance P'.ReflectEnum Label where+        reflectEnum+          = [(1, "LABEL_OPTIONAL", LABEL_OPTIONAL),+             (2, "LABEL_REQUIRED", LABEL_REQUIRED),+             (3, "LABEL_REPEATED", LABEL_REPEATED)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldDescriptorProto"+                 "Label")+              [(1, "LABEL_OPTIONAL"), (2, "LABEL_REQUIRED"),+               (3, "LABEL_REPEATED")]++{-module Text.DescriptorProtos.FieldDescriptorProto.Label (Label(..))+       where+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data Label = LABEL_OPTIONAL+           | LABEL_REQUIRED+           | LABEL_REPEATED+           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Label+ +instance P'.Bounded Label where+        minBound = LABEL_OPTIONAL+        maxBound = LABEL_REPEATED+ +instance P'.Default Label where+        defaultValue = P'.minBound+ +instance P'.Enum Label where+        fromEnum (LABEL_OPTIONAL) = 1+        fromEnum (LABEL_REQUIRED) = 2+        fromEnum (LABEL_REPEATED) = 3+        toEnum 1 = LABEL_OPTIONAL+        toEnum 2 = LABEL_REQUIRED+        toEnum 3 = LABEL_REPEATED+        succ (LABEL_OPTIONAL) = LABEL_REQUIRED+        succ (LABEL_REQUIRED) = LABEL_REPEATED+        pred (LABEL_REQUIRED) = LABEL_OPTIONAL+        pred (LABEL_REPEATED) = LABEL_REQUIRED+ +instance P'.ReflectEnum Label where+        reflectEnum+          = [(1, "LABEL_OPTIONAL", LABEL_OPTIONAL),+             (2, "LABEL_REQUIRED", LABEL_REQUIRED),+             (3, "LABEL_REPEATED", LABEL_REPEATED)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldDescriptorProto"+                 "Label")+              [(1, "LABEL_OPTIONAL"), (2, "LABEL_REQUIRED"),+               (3, "LABEL_REPEATED")]++{-module Text.DescriptorProtos.FieldDescriptorProto.Label (Label(..))+       where+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data Label = LABEL_OPTIONAL+           | LABEL_REQUIRED+           | LABEL_REPEATED+           deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Label+ +instance P'.Mergeable (P'.Maybe Label) where+        mergeEmpty = P'.Nothing+        mergeAppend = P'.mayMerge+ +instance P'.Enum Label where+        fromEnum (LABEL_OPTIONAL) = 1+        fromEnum (LABEL_REQUIRED) = 2+        fromEnum (LABEL_REPEATED) = 3+        toEnum 1 = LABEL_OPTIONAL+        toEnum 2 = LABEL_REQUIRED+        toEnum 3 = LABEL_REPEATED+        succ (LABEL_OPTIONAL) = LABEL_REQUIRED+        succ (LABEL_REQUIRED) = LABEL_REPEATED+        pred (LABEL_REQUIRED) = LABEL_OPTIONAL+        pred (LABEL_REPEATED) = LABEL_REQUIRED+ +instance P'.Bounded Label where+        minBound = LABEL_OPTIONAL+        maxBound = LABEL_REPEATED+ +ascList' :: [] (P'.Integer, P'.String, Label)+ascList'+  = [(1, "LABEL_OPTIONAL", LABEL_OPTIONAL),+     (2, "LABEL_REQUIRED", LABEL_REQUIRED),+     (3, "LABEL_REPEATED", LABEL_REPEATED)]++{-+module Text.DescriptorProtos.FieldDescriptorProto.Label+  (Label(..))+ where++import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'++{-+data Label = LABEL_OPTIONAL+           | LABEL_REQUIRED+           | LABEL_REPEATED+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeableEnum ''Label )+-}-}-}-}-}
+ Text/Hand-DescriptorProtos/FieldDescriptorProto/Type.hs view
@@ -0,0 +1,162 @@+module Text.DescriptorProtos.FieldDescriptorProto.Type (Type(..))+       where+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+ +data Type = TYPE_DOUBLE+          | TYPE_FLOAT+          | TYPE_INT64+          | TYPE_UINT64+          | TYPE_INT32+          | TYPE_FIXED64+          | TYPE_FIXED32+          | TYPE_BOOL+          | TYPE_STRING+          | TYPE_GROUP+          | TYPE_MESSAGE+          | TYPE_BYTES+          | TYPE_UINT32+          | TYPE_ENUM+          | TYPE_SFIXED32+          | TYPE_SFIXED64+          | TYPE_SINT32+          | TYPE_SINT64+          deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable Type where+ +instance P'.Bounded Type where+        minBound = TYPE_DOUBLE+        maxBound = TYPE_SINT64+ +instance P'.Default Type where+        defaultValue = TYPE_DOUBLE+ +instance P'.Enum Type where+        fromEnum (TYPE_DOUBLE) = 1+        fromEnum (TYPE_FLOAT) = 2+        fromEnum (TYPE_INT64) = 3+        fromEnum (TYPE_UINT64) = 4+        fromEnum (TYPE_INT32) = 5+        fromEnum (TYPE_FIXED64) = 6+        fromEnum (TYPE_FIXED32) = 7+        fromEnum (TYPE_BOOL) = 8+        fromEnum (TYPE_STRING) = 9+        fromEnum (TYPE_GROUP) = 10+        fromEnum (TYPE_MESSAGE) = 11+        fromEnum (TYPE_BYTES) = 12+        fromEnum (TYPE_UINT32) = 13+        fromEnum (TYPE_ENUM) = 14+        fromEnum (TYPE_SFIXED32) = 15+        fromEnum (TYPE_SFIXED64) = 16+        fromEnum (TYPE_SINT32) = 17+        fromEnum (TYPE_SINT64) = 18+        toEnum 1 = TYPE_DOUBLE+        toEnum 2 = TYPE_FLOAT+        toEnum 3 = TYPE_INT64+        toEnum 4 = TYPE_UINT64+        toEnum 5 = TYPE_INT32+        toEnum 6 = TYPE_FIXED64+        toEnum 7 = TYPE_FIXED32+        toEnum 8 = TYPE_BOOL+        toEnum 9 = TYPE_STRING+        toEnum 10 = TYPE_GROUP+        toEnum 11 = TYPE_MESSAGE+        toEnum 12 = TYPE_BYTES+        toEnum 13 = TYPE_UINT32+        toEnum 14 = TYPE_ENUM+        toEnum 15 = TYPE_SFIXED32+        toEnum 16 = TYPE_SFIXED64+        toEnum 17 = TYPE_SINT32+        toEnum 18 = TYPE_SINT64+        succ (TYPE_DOUBLE) = TYPE_FLOAT+        succ (TYPE_FLOAT) = TYPE_INT64+        succ (TYPE_INT64) = TYPE_UINT64+        succ (TYPE_UINT64) = TYPE_INT32+        succ (TYPE_INT32) = TYPE_FIXED64+        succ (TYPE_FIXED64) = TYPE_FIXED32+        succ (TYPE_FIXED32) = TYPE_BOOL+        succ (TYPE_BOOL) = TYPE_STRING+        succ (TYPE_STRING) = TYPE_GROUP+        succ (TYPE_GROUP) = TYPE_MESSAGE+        succ (TYPE_MESSAGE) = TYPE_BYTES+        succ (TYPE_BYTES) = TYPE_UINT32+        succ (TYPE_UINT32) = TYPE_ENUM+        succ (TYPE_ENUM) = TYPE_SFIXED32+        succ (TYPE_SFIXED32) = TYPE_SFIXED64+        succ (TYPE_SFIXED64) = TYPE_SINT32+        succ (TYPE_SINT32) = TYPE_SINT64+        pred (TYPE_FLOAT) = TYPE_DOUBLE+        pred (TYPE_INT64) = TYPE_FLOAT+        pred (TYPE_UINT64) = TYPE_INT64+        pred (TYPE_INT32) = TYPE_UINT64+        pred (TYPE_FIXED64) = TYPE_INT32+        pred (TYPE_FIXED32) = TYPE_FIXED64+        pred (TYPE_BOOL) = TYPE_FIXED32+        pred (TYPE_STRING) = TYPE_BOOL+        pred (TYPE_GROUP) = TYPE_STRING+        pred (TYPE_MESSAGE) = TYPE_GROUP+        pred (TYPE_BYTES) = TYPE_MESSAGE+        pred (TYPE_UINT32) = TYPE_BYTES+        pred (TYPE_ENUM) = TYPE_UINT32+        pred (TYPE_SFIXED32) = TYPE_ENUM+        pred (TYPE_SFIXED64) = TYPE_SFIXED32+        pred (TYPE_SINT32) = TYPE_SFIXED64+        pred (TYPE_SINT64) = TYPE_SINT32+ +instance P'.Wire Type where+        wireSize 14 enum = P'.wireSize 14 (P'.fromEnum enum)+        wirePut 14 enum = P'.wirePut 14 (P'.fromEnum enum)+        wireGet 14 = P'.fmap P'.toEnum (P'.wireGet 14)+ +instance P'.ReflectEnum Type where+        reflectEnum+          = [(1, "TYPE_DOUBLE", TYPE_DOUBLE), (2, "TYPE_FLOAT", TYPE_FLOAT),+             (3, "TYPE_INT64", TYPE_INT64), (4, "TYPE_UINT64", TYPE_UINT64),+             (5, "TYPE_INT32", TYPE_INT32), (6, "TYPE_FIXED64", TYPE_FIXED64),+             (7, "TYPE_FIXED32", TYPE_FIXED32), (8, "TYPE_BOOL", TYPE_BOOL),+             (9, "TYPE_STRING", TYPE_STRING), (10, "TYPE_GROUP", TYPE_GROUP),+             (11, "TYPE_MESSAGE", TYPE_MESSAGE), (12, "TYPE_BYTES", TYPE_BYTES),+             (13, "TYPE_UINT32", TYPE_UINT32), (14, "TYPE_ENUM", TYPE_ENUM),+             (15, "TYPE_SFIXED32", TYPE_SFIXED32),+             (16, "TYPE_SFIXED64", TYPE_SFIXED64),+             (17, "TYPE_SINT32", TYPE_SINT32), (18, "TYPE_SINT64", TYPE_SINT64)]+        reflectEnumInfo _+          = P'.EnumInfo+              (P'.ProtoName "Text" "DescriptorProtos.FieldDescriptorProto"+                 "Type")+              [(1, "TYPE_DOUBLE"), (2, "TYPE_FLOAT"), (3, "TYPE_INT64"),+               (4, "TYPE_UINT64"), (5, "TYPE_INT32"), (6, "TYPE_FIXED64"),+               (7, "TYPE_FIXED32"), (8, "TYPE_BOOL"), (9, "TYPE_STRING"),+               (10, "TYPE_GROUP"), (11, "TYPE_MESSAGE"), (12, "TYPE_BYTES"),+               (13, "TYPE_UINT32"), (14, "TYPE_ENUM"), (15, "TYPE_SFIXED32"),+               (16, "TYPE_SFIXED64"), (17, "TYPE_SINT32"), (18, "TYPE_SINT64")]+{-module Text.DescriptorProtos.FieldDescriptorProto.Type+  (Type(..))+ where++import Text.ProtocolBuffers.Header++data Type = TYPE_DOUBLE+          | TYPE_FLOAT+          | TYPE_INT64    -- inefficient for negative values+          | TYPE_UINT64+          | TYPE_INT32    -- inefficient for negative values+          | TYPE_FIXED64+          | TYPE_FIXED32+          | TYPE_BOOL+          | TYPE_STRING+          | TYPE_GROUP      -- Tag-delimited aggregate.+          | TYPE_MESSAGE    -- Length-delimeted aggegate+            -- descriptor.proto "New in version 2"+          | TYPE_BYTES+          | TYPE_UINT32+          | TYPE_ENUM+          | TYPE_SFIXED32+          | TYPE_SFIXED64+          | TYPE_SINT32 -- Uses ZipZag encoding+          | TYPE_SINT64 -- Uses ZipZag encoding+  deriving (Show,Read,Eq,Ord,Typeable,Data,Enum)++$( makeMergeableEnum ''Type )+-}
+ Text/Hand-DescriptorProtos/FieldOptions.hs view
@@ -0,0 +1,116 @@+-- *Text.ProtocolBuffers.Gen Numeric> putStrLn . prettyPrint . descriptorModule "Text" $ genFieldOptions+module Text.DescriptorProtos.FieldOptions (FieldOptions(..)) where+import Prelude ((+), (++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.FieldOptions.CType+       as DescriptorProtos.FieldOptions (CType)+ +data FieldOptions = FieldOptions{ctype ::+                                 P'.Maybe DescriptorProtos.FieldOptions.CType,+                                 experimental_map_key :: P'.Maybe P'.ByteString}+                  deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable FieldOptions where+        mergeEmpty = FieldOptions P'.mergeEmpty P'.mergeEmpty+        mergeAppend (FieldOptions x'1 x'2) (FieldOptions y'1 y'2)+          = FieldOptions (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+ +instance P'.Default FieldOptions where+        defaultValue+          = FieldOptions (P'.Just P'.defaultValue) (P'.Just P'.defaultValue)+ +instance P'.Wire FieldOptions where+        wireSize 11 (FieldOptions x'1 x'2)+          = P'.lenSize (P'.wireSizeOpt 1 14 x'1 + P'.wireSizeOpt 1 9 x'2)+        wirePut 11 self'@(FieldOptions x'1 x'2)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 8 14 x'1+               P'.wirePutOpt 74 9 x'2+        wireGet 11 = P'.getMessage update'Self+         where+          update'Self field'Number old'Self =+            case field'Number of+              1 -> P'.fmap (\new'Field -> old'Self { ctype = P'.Just new'Field }) (P'.wireGet 14)+              9 -> P'.fmap (\new'Field -> old'Self { experimental_map_key = P'.Just new'Field }) (P'.wireGet 9)+              _ -> P'.unknownField field'Number+--P'.fail ("Impossible? Message asked to parse an unknown field number on wire: "++P'.show field'Number)+ +instance P'.ReflectDescriptor FieldOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"FieldOptions\"}, fields = fromList [FieldInfo {fieldName = \"ctype\", fieldNumber = FieldId {getFieldID = 1}, wireTag = WireTag {getWireTag = 8}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 14}, typeName = Just \"DescriptorProtos.FieldOptions.CType\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"experimental_map_key\", fieldNumber = FieldId {getFieldID = 9}, wireTag = WireTag {getWireTag = 74}, wireTagLength = 1, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}]}"+++{-+module Text.DescriptorProtos.FieldOptions (FieldOptions(..)) where+import Prelude((+),(>>),(>>=),(++))+import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Text.DescriptorProtos.FieldOptions.CType+       as DescriptorProtos.FieldOptions (CType)+ +data FieldOptions = FieldOptions{ctype ::+                                 P'.Maybe DescriptorProtos.FieldOptions.CType,+                                 experimental_map_key :: P'.Maybe P'.ByteString}+                  deriving (P'.Show, P'.Read, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable FieldOptions where+        mergeEmpty = FieldOptions P'.mergeEmpty P'.mergeEmpty+        mergeAppend (FieldOptions x'1 x'2) (FieldOptions y'1 y'2)+          = FieldOptions (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+ +instance P'.Default FieldOptions where+        defaultValue+          = FieldOptions (P'.Just P'.defaultValue) (P'.Just P'.defaultValue)++-- Hand written, then I'll create the Gen.hs code+instance P'.Wire FieldOptions where+        wireSize 11 (FieldOptions x'1 x'2)+          = P'.lenSize (P'.wireSizeOpt 14 x'1 + P'.wireSizeOpt 9 x'2)+        wirePut 11 self'@(FieldOptions x'1 x'2)+          = do P'.putSize (P'.wireSize 11 self')+               P'.wirePutOpt 8 14 x'1+               P'.wirePutOpt 74 9 x'2+{-+  wireSize 11 (FieldOptions x'1 x'2) = P'.lenSize (P'.wireSizeOpt 11 x'1 + P'.wireSizeOpt 9 x'2)+  wirePut 11 self'@(FieldOptions x'1 x'2) = do P'.putSize (P'.wireSize 11 self')+                                               P'.wirePutOpt 10 11 x'1+                                               P'.wirePutOpt 74  9 x'2+-}+        wireGet 11 = P'.getMessage update'Self+         where -- updater :: P'.Updater FieldOptions+          update'Self field'Number old'Self =+            case field'Number of+              1 -> P'.fmap (\new'Field -> old'Self { ctype = P'.Just new'Field }) (P'.wireGet 11)+              9 -> P'.fmap (\new'Field -> old'Self { experimental_map_key = P'.Just new'Field }) (P'.wireGet 9)+--           10 -> P'.fmap (\new'Field -> old'Self { requiredField = new'Field }) (P'.wireGet 4)+--           11 -> P'.fmap (\new'Field -> old'Self { repeatedField = P'.append (repeatedField old'Self) new'Field }) (P'.wireGet 5)+              _ -> P'.fail ("Impossible? Message asked to parse an unknown field number on wire: "++P'.show field'Number)+ +instance P'.ReflectDescriptor FieldOptions where+        reflectDescriptorInfo _+          = P'.read+              "DescriptorInfo {descName = ProtoName {haskellPrefix = \"Text\", parentModule = \"DescriptorProtos\", baseName = \"FieldOptions\"}, fields = fromList [FieldInfo {fieldName = \"ctype\", fieldNumber = FieldId {getFieldID = 1}, wireTag = WireTag {getWireTag = 8}, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 14}, typeName = Just \"DescriptorProtos.FieldOptions.CType\", hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = \"experimental_map_key\", fieldNumber = FieldId {getFieldID = 9}, wireTag = WireTag {getWireTag = 74}, isRequired = False, canRepeat = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}]}"++++{-module Text.DescriptorProtos.FieldOptions+  (FieldOptions(..))+ where++import Text.ProtocolBuffers.Header++import qualified Text.DescriptorProtos.FieldOptions.CType as DescriptorProtos.FieldOptions(CType)++data FieldOptions = FieldOptions+    { ctype :: Maybe DescriptorProtos.FieldOptions.CType+    , experimental_map_key :: Maybe ByteString+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''FieldOptions )++instance Default FieldOptions where++-}-}
+ Text/Hand-DescriptorProtos/FieldOptions/CType.hs view
@@ -0,0 +1,19 @@+module Text.DescriptorProtos.FieldOptions.CType+  (CType(..))+ where++import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'++data CType = CORD | STRING_PIECE+  deriving (P'.Show,P'.Read,P'.Eq,P'.Ord,P'.Data,P'.Typeable)++-- $( P'.makeMergeableEnum ''CType )++instance P'.Mergeable CType++instance P'.Default CType++instance P'.Wire CType++instance P'.ReflectEnum CType
+ Text/Hand-DescriptorProtos/FileDescriptorProto.hs view
@@ -0,0 +1,26 @@+module Text.DescriptorProtos.FileDescriptorProto+  (FileDescriptorProto(..))+ where++import Text.ProtocolBuffers.Header+import qualified Text.DescriptorProtos.DescriptorProto as DescriptorProtos(DescriptorProto) +import qualified Text.DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) +import qualified Text.DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) +import qualified Text.DescriptorProtos.FileOptions as DescriptorProtos(FileOptions)+import qualified Text.DescriptorProtos.ServiceDescriptorProto as DescriptorProtos(ServiceDescriptorProto) ++data FileDescriptorProto = FileDescriptorProto+    { name :: Maybe ByteString+    , package :: Maybe ByteString+    , dependency :: Seq ByteString+    , message_type :: Seq DescriptorProtos.DescriptorProto+    , enum_type :: Seq DescriptorProtos.EnumDescriptorProto+    , service :: Seq DescriptorProtos.ServiceDescriptorProto+    , extension :: Seq DescriptorProtos.FieldDescriptorProto+    , options :: Maybe DescriptorProtos.FileOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''FileDescriptorProto )++instance Default FileDescriptorProto where
+ Text/Hand-DescriptorProtos/FileOptions.hs view
@@ -0,0 +1,23 @@+module Text.DescriptorProtos.FileOptions+  (FileOptions(..))+ where++import Text.ProtocolBuffers.Header+import qualified Text.DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions(OptimizeMode)+import qualified Text.DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions.OptimizeMode(OptimizeMode(..))++data FileOptions = FileOptions+    { java_package :: Maybe ByteString+    , java_outer_classname :: Maybe ByteString+    , java_multiple_files :: Maybe Bool+    , optimize_for :: Maybe DescriptorProtos.FileOptions.OptimizeMode+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''FileOptions )++instance Default FileOptions where+  defaultValue = mergeEmpty+    { java_multiple_files = Just False+    , optimize_for = Just DescriptorProtos.FileOptions.OptimizeMode.CODE_SIZE+    }
+ Text/Hand-DescriptorProtos/FileOptions/OptimizeMode.hs view
@@ -0,0 +1,33 @@+module Text.DescriptorProtos.FileOptions.OptimizeMode+  (OptimizeMode(..))+ where++import Data.Monoid+import Text.ProtocolBuffers.Header++data OptimizeMode = SPEED | CODE_SIZE+  deriving (Read,Show,Eq,Ord,Typeable)++$( makeMergeableEnum ''OptimizeMode )++err'Name :: String+err'Name = "DescriptorProtos.FileOptions.OptimizeMode"++err' :: String -> b+err' a = error (err'Name ++ " : " ++ show a)++instance Enum OptimizeMode where+  fromEnum SPEED = 1+  fromEnum CODE_SIZE = 2++  toEnum 1 = SPEED+  toEnum 2 = CODE_SIZE+  toEnum x = err' ("toEnum failed on value "++show x)++  succ SPEED = CODE_SIZE+  succ CODE_SIZE = err' ("succ failed on value "++show CODE_SIZE)++  pred SPEED = err' ("pred failed on value "++show SPEED)+  pred CODE_SIZE = SPEED++instance ReflectEnum OptimizeMode where
+ Text/Hand-DescriptorProtos/MessageOptions.hs view
@@ -0,0 +1,17 @@+module Text.DescriptorProtos.MessageOptions+  (MessageOptions(..))+ where++import Text.ProtocolBuffers.Header++data MessageOptions = MessageOptions+    { message_set_wire_format :: Maybe Bool+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''MessageOptions )++instance Default MessageOptions where+  defaultValue = mergeEmpty+    { message_set_wire_format = Just False+    }
+ Text/Hand-DescriptorProtos/MethodDescriptorProto.hs view
@@ -0,0 +1,18 @@+module Text.DescriptorProtos.MethodDescriptorProto+  (MethodDescriptorProto(..))+ where++import Text.ProtocolBuffers.Header+import qualified Text.DescriptorProtos.MethodOptions as DescriptorProtos(MethodOptions)++data MethodDescriptorProto = MethodDescriptorProto+    { name :: Maybe ByteString+    , input_type :: Maybe ByteString+    , output_type :: Maybe ByteString+    , options :: Maybe DescriptorProtos.MethodOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''MethodDescriptorProto )++instance Default MethodDescriptorProto where
+ Text/Hand-DescriptorProtos/MethodOptions.hs view
@@ -0,0 +1,12 @@+module Text.DescriptorProtos.MethodOptions+  (MethodOptions(..))+ where++import Text.ProtocolBuffers.Header++data MethodOptions = MethodOptions+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''MethodOptions )++instance Default MethodOptions where
+ Text/Hand-DescriptorProtos/ServiceDescriptorProto.hs view
@@ -0,0 +1,19 @@+module Text.DescriptorProtos.ServiceDescriptorProto+  (ServiceDescriptorProto(..))+ where++import Text.ProtocolBuffers.Header++import qualified Text.DescriptorProtos.MethodDescriptorProto as DescriptorProtos(MethodDescriptorProto)+import qualified Text.DescriptorProtos.ServiceOptions as DescriptorProtos(ServiceOptions)++data ServiceDescriptorProto = ServiceDescriptorProto+    { name :: Maybe ByteString+    , method :: Seq DescriptorProtos.MethodDescriptorProto+    , options :: Maybe DescriptorProtos.ServiceOptions+    }+  deriving (Show,Eq,Ord,Typeable)++$( makeMergeable ''ServiceDescriptorProto )++instance Default ServiceDescriptorProto where
+ Text/Hand-DescriptorProtos/ServiceOptions.hs view
@@ -0,0 +1,47 @@+module Text.DescriptorProtos.ServiceOptions+  (ServiceOptions(..))+ where++import qualified Prelude as P'+import qualified Text.ProtocolBuffers.Header as P'++data ServiceOptions = ServiceOptions+                    deriving (P'.Show, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable ServiceOptions where+        mergeEmpty = ServiceOptions+        mergeAppend (ServiceOptions) (ServiceOptions) = ServiceOptions+ +instance P'.Default ServiceOptions++{-+data ServiceOptions = ServiceOptions{field1 ::+                                     P'.Maybe P'.ByteString,+                                     field2 :: P'.Maybe ServiceOptions}+                    deriving (P'.Show, P'.Eq, P'.Ord, P'.Data, P'.Typeable)+ +instance P'.Mergeable ServiceOptions where+        mergeEmpty = ServiceOptions P'.mergeEmpty P'.mergeEmpty+        mergeAppend (ServiceOptions x'1 x'2) (ServiceOptions y'1 y'2)+          = ServiceOptions (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2)+ +instance P'.Mergeable (P'.Maybe ServiceOptions) where+        mergeEmpty = P'.Nothing+        mergeAppend = P'.mayMerge+ +instance P'.Default ServiceOptions+-}+{-+data ServiceOptions = ServiceOptions+  deriving (P'.Show,P'.Eq,P'.Ord,P'.Typeable)++instance P'.Mergeable ServiceOptions where+        mergeEmpty = ServiceOptions+        mergeAppend = P'.mergeAppend+ +instance P'.Mergeable (P'.Maybe ServiceOptions) where+        mergeEmpty = P'.Nothing+        mergeAppend = P'.mayMerge++instance P'.Default ServiceOptions+-}
+ Text/ProtocolBuffers/Builder.hs view
@@ -0,0 +1,6 @@+module Text.ProtocolBuffers.Builder where++class Builder a where+  getBuildInfo :: a -> Int -> Maybe BuildInfo++
Text/ProtocolBuffers/Default.hs view
@@ -1,7 +1,24 @@ module Text.ProtocolBuffers.Default(Default(..)) where -import Text.ProtocolBuffers.Mergeable+import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Mergeable (Mergeable(mergeEmpty)) +-- Anything with an "mempty / mergeEmpty" can be a trivial "Mondad / Mergeable"+--+-- So it makes some sense to make the default defaultValue be this empty value class Mergeable a => Default a where   defaultValue :: a   defaultValue = mergeEmpty++instance Default a => Default (Maybe a) where defaultValue = Just defaultValue++-- Take the mergeEmpty as the defaultValue+instance Default (Seq a) where+instance Default Bool where+instance Default ByteString where+instance Default Double where+instance Default Float where+instance Default Int32 where+instance Default Int64 where+instance Default Word32 where+instance Default Word64 where
Text/ProtocolBuffers/DeriveMergeable.hs view
@@ -19,10 +19,11 @@     mergeAppend = mayMerge  |] --makeMergeable t = liftM2 (++) (derive makeMergeable1 t) (derive makeMergeable2 t)+--makeMergeable t = liftM2 (++) (derive makeMergeable1 t) (derive makeMergeable2 t)+makeMergeable t = derive makeMergeable1 t -makeMergeableEnum t = liftM2 (++) (derive makeMergeable1Enum t) (derive makeMergeable2Enum t)+makeMergeableEnum t = derive makeMergeable1Enum t+-- makeMergeableEnum t = liftM2 (++) (derive makeMergeable1Enum t) (derive makeMergeable2Enum t)  makeMergeable1 :: Derivation makeMergeable1 = derivation mergeable1' "Mergeable"@@ -37,7 +38,7 @@                          lK (ctorName ctor) (zipWith (l2 "mergeAppend") (ctv ctor 'x') (ctv ctor 'y'))  mergeable1' dat = []-+{- makeMergeable2 :: Derivation makeMergeable2 = derivation mergeable2' "Mergeable2" --  instance Mergeable (Maybe a) where@@ -50,7 +51,7 @@                              ,(ValD (VarP (mkName "mergeAppend"))                                     (NormalB (VarE (mkName "mayMerge"))) [])]]   where foo = dataName dat-+-}  makeMergeable1Enum :: Derivation makeMergeable1Enum = derivation mergeable1Enum' "Mergeable1Enum"@@ -60,7 +61,7 @@                                          (ConT (mkName foo)))                              []]   where foo = dataName dat-+{- makeMergeable2Enum :: Derivation makeMergeable2Enum = derivation mergeable2Enum' "Mergeable2Enum" --  instance Mergeable (Maybe a) where@@ -73,7 +74,7 @@                              ,(ValD (VarP (mkName "mergeAppend"))                                     (NormalB (VarE (mkName "mayMerge"))) [])]]   where foo = dataName dat-+-} {- --  instance Mergeable a => Mergeable (Maybe a) where mergeable2' dat = [InstanceD (concat ([[(AppT (ConT (mkName "Mergeable"))
Text/ProtocolBuffers/Gen.hs view
@@ -1,10 +1,45 @@+-- try "test", "testDesc", and "testLabel" to see sample output+-- -- Turn *Proto into Language.Haskell.Exts.Syntax from haskell-src-exts package-module Text.ProtocolBuffers.Gen where+-- Need to get this just far enough to allow bootstrapping of 'descriptor.proto'+-- Done: Enum modules+-- Done: Descriptor modules (except for default values and reflection)+--+-- Note that this must eventually also generate hs-boot files to allow+-- for breaking mutual recursion.  This is ignored for getting+-- descriptor.proto running.+--+-- Mangling: For the current moment, assume the mangling is done in a prior pass:+--   (*) Uppercase all module names and type names+--   (*) lowercase all field names+--   (*) add a prime after all field names than conflict with reserved words+--+-- The names are also assumed to have become fully-qualified, and all+-- the optional type codes have been set.+--+-- default values are an awful mess.  They are documented in descriptor.proto as+{-+  // For numeric types, contains the original text representation of the value.+  // For booleans, "true" or "false".+  // For strings, contains the default text contents (not escaped in any way).+  // For bytes, contains the C escaped value.  All bytes >= 128 are escaped.+  // TODO(kenton):  Base-64 encode?+  optional string default_value = 7;+-}+-- The above fails to mentions enums' default is their first value (always exists)+-- see something like http://msdn.microsoft.com/en-us/library/6aw8xdf2.aspx for c escape parsing+-- So rendering a message to text is ugly, the strings are valid UTF-8 and so are rendered in+-- some other unicode form, while bytes must be unparsed to use. The only sane thing to do is+-- put a parsed and converted Haskell data type into the defaults interface.+-- This has been done in Reflections.hs+module Text.ProtocolBuffers.Gen(descriptorModule,enumModule,prettyPrint) where+ import qualified Text.DescriptorProtos.DescriptorProto                as D(DescriptorProto) import qualified Text.DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))-{-+{- not yet used import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto(ExtensionRange) import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto.ExtensionRange(ExtensionRange(..))+-} import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto)  import qualified Text.DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..))  import qualified Text.DescriptorProtos.EnumOptions                    as D(EnumOptions)@@ -13,28 +48,29 @@ import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..)) import qualified Text.DescriptorProtos.EnumValueOptions               as D(EnumValueOptions)  import qualified Text.DescriptorProtos.EnumValueOptions               as D.EnumValueOptions(EnumValueOptions(..)) --} import qualified Text.DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto)  import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..))  import qualified Text.DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto(Label) import           Text.DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto.Label(Label(..)) import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type) import           Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto.Type(Type(..))-{- import qualified Text.DescriptorProtos.FieldOptions                   as D(FieldOptions) import qualified Text.DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))-import qualified Text.DescriptorProtos.FieldOptions.CType             as D.FieldOptions(CType)-import qualified Text.DescriptorProtos.FieldOptions.CType             as D.FieldOptions.CType(CType(..))-import qualified Text.DescriptorProtos.FileOptions                    as D(FileOptions) import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto)  import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..)) +import qualified Text.DescriptorProtos.FileOptions                    as D(FileOptions) import qualified Text.DescriptorProtos.FileOptions                    as D.FileOptions(FileOptions(..))+{- -- unused or unusable+import qualified Text.DescriptorProtos.FieldOptions.CType             as D.FieldOptions(CType)+import qualified Text.DescriptorProtos.FieldOptions.CType             as D.FieldOptions.CType(CType(..)) import qualified Text.DescriptorProtos.FileOptions.OptimizeMode       as D.FileOptions(OptimizeMode) import qualified Text.DescriptorProtos.FileOptions.OptimizeMode       as D.FileOptions.OptimizeMode(OptimizeMode(..))-import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto)-import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..)) import qualified Text.DescriptorProtos.MessageOptions                 as D(MessageOptions) import qualified Text.DescriptorProtos.MessageOptions                 as D.MessageOptions(MessageOptions(..))+-}+{-  -- related to the rpc system+import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto)+import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..)) import qualified Text.DescriptorProtos.MethodOptions                  as D(MethodOptions) import qualified Text.DescriptorProtos.MethodOptions                  as D.MethodOptions(MethodOptions(..)) import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D(ServiceDescriptorProto) @@ -42,71 +78,309 @@ import qualified Text.DescriptorProtos.ServiceOptions                 as D(ServiceOptions) import qualified Text.DescriptorProtos.ServiceOptions                 as D.ServiceOptions(ServiceOptions(..)) -}-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.UTF8 as U -import Text.ProtocolBuffers.Header--import Data.Sequence(Seq)-import qualified Data.Sequence as S-import Data.Foldable as F+--import Text.ProtocolBuffers.Header+import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Default+import Text.ProtocolBuffers.Reflections+import Text.ProtocolBuffers.WireMessage(size'Varint) +import qualified Data.ByteString(concat)+import qualified Data.ByteString.Char8(spanEnd)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BSC+import qualified Data.ByteString.Lazy.UTF8 as U+import Data.Bits(Bits((.|.),shiftL))+import Data.Maybe(fromMaybe,catMaybes)+import Data.List(sort,group,foldl',foldl1')+import Data.Sequence(viewl,ViewL(..))+import qualified Data.Sequence as Seq(length,fromList)+import Data.Foldable as F(foldr,toList) import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.Pretty --- This is me playing around to learn the whole module syntax tree---src = (SrcLoc {srcFilename = "/tmp/M.hs",srcLine=1,srcColumn=1})-m = HsModule src-             (Module "A.B.C")-             (Just [HsEVar (name "x")])-             ([HsImportDecl src (Module "Data.Int") True (Just (Module "In"))-                            (Just (True, [HsIAbs (HsIdent "Int8")-                                         ,HsIAbs (HsIdent "Int16")-                                         ]))-              ])-             [HsTypeSig src [HsIdent "x"] (HsTyCon (Qual (Module "In") (HsIdent "Int32")))-             ,HsPatBind src (HsPVar (HsIdent "x")) (HsUnGuardedRhs (HsLit (HsInt 11)))-                        (HsBDecls [HsPatBind src (HsPVar (HsIdent "y")) (HsUnGuardedRhs (HsLit (HsInt 12))) -                                             (HsBDecls [])-                                  ])-             ,HsSpliceDecl src (HsParenSplice (HsApp (HsVar (name "deriveIt")) (HsReifyExp (HsReifyDecl (name "Integer")))))-             ]-  where name s = UnQual (HsIdent s)+-- -- -- -- Helper functions -print_m = putStrLn (prettyPrint m)  -{--module A.B.C (x) where-import qualified Data.Int as In hiding (Int8, Int16)- -x :: In.Int32-x = 11-  where y = 12--}+($$) :: HsExp -> HsExp -> HsExp+($$) = HsApp -{- ***************************************************************************************** -}--- 'descriptorX' renders a DescriptorProto to a data declaration.--- 'fieldX' renders a FieldDescriptorProto to an entry in a data declaration.-{- ***************************************************************************************** -}+infixl 1 $$ +toWireTag :: FieldId -> FieldType -> WireTag+toWireTag fieldId fieldType+    = ((fromIntegral . getFieldId $ fieldId) `shiftL` 3) .|. (fromIntegral . getWireType . toWireType $ fieldType)++{-  TYPE_DOUBLE         = 1;+    TYPE_FLOAT          = 2;+    TYPE_INT64          = 3;+    TYPE_UINT64         = 4;+    TYPE_INT32          = 5;+    TYPE_FIXED64        = 6;+    TYPE_FIXED32        = 7;+    TYPE_BOOL           = 8;+    TYPE_STRING         = 9;+    TYPE_GROUP          = 10;  // Tag-delimited aggregate.+    TYPE_MESSAGE        = 11;+    TYPE_BYTES          = 12;+    TYPE_UINT32         = 13;+    TYPE_ENUM           = 14;+    TYPE_SFIXED32       = 15;+    TYPE_SFIXED64       = 16;+    TYPE_SINT32         = 17;+    TYPE_SINT64         = 18; -}+-- http://code.google.com/apis/protocolbuffers/docs/encoding.html+toWireType :: FieldType -> WireType+toWireType  1 =  1+toWireType  2 =  5+toWireType  3 =  0+toWireType  4 =  0+toWireType  5 =  0+toWireType  6 =  1+toWireType  7 =  5+toWireType  8 =  0+toWireType  9 =  2+toWireType 10 =  error "TYPE_GROUP unsupported ..."+toWireType 11 =  2+toWireType 12 =  2+toWireType 13 =  0+toWireType 14 =  0+toWireType 15 =  5+toWireType 16 =  1+toWireType 17 =  5+toWireType 18 =  1+toWireType _ = error "WireMessage.toWireType: Bad FieldType"++dotPre :: String -> String -> String+dotPre "" = id+dotPre s | '.' == last s = (s ++)+         | otherwise = (s ++) . ('.':)++spanEndL f bs = let (a,b) = Data.ByteString.Char8.spanEnd f (Data.ByteString.concat . BSC.toChunks $ bs)+                in (BSC.fromChunks [a],BSC.fromChunks [b])++-- Take a bytestring of "A" into "Right A" and "A.B.C" into "Left (A.B,C)"+splitMod :: ByteString -> Either (ByteString,ByteString) ByteString+splitMod bs = case spanEndL ('.'/=) bs of+                (pre,post) | BSC.length pre <= 1 -> Right bs+                           | otherwise -> Left (BSC.init pre,post)++unqual :: ByteString -> HsQName+unqual bs = UnQual (base bs)++base :: ByteString -> HsName+base bs = case splitMod bs of+            Right typeName -> (ident typeName)+            Left (_,typeName) -> (ident typeName)+ src :: SrcLoc-src = error "No SrcLoc"+src = SrcLoc "No SrcLoc" 0 0  ident :: ByteString -> HsName ident bs = HsIdent (U.toString bs)  typeApp :: String -> HsType -> HsType-typeApp s =  HsTyApp (HsTyCon (UnQual (HsIdent s)))+typeApp s =  HsTyApp (HsTyCon (private s))  -- 'qual' and 'qmodname' are only correct for simple or fully looked-up names. qual :: ByteString -> HsQName-qual bs = case BSC.spanEnd ('.'/=) bs of-            (pre,post) | BSC.length pre <= 1 -> UnQual (ident bs)-                       | otherwise -> qmodname (BSC.init pre) post+qual bs = case splitMod bs of+            Right typeName -> UnQual (ident typeName)+            Left (modName,typeName) -> Qual (Module (U.toString modName)) (ident typeName) -qmodname :: ByteString -> ByteString -> HsQName-qmodname modName typeName = Qual (Module (U.toString modName)) (ident typeName)+pvar :: String -> HsExp+pvar t = HsVar (private t) +lvar :: String -> HsExp+lvar t = HsVar (UnQual (HsIdent t))++private :: String -> HsQName+private t = Qual (Module "P'") (HsIdent t)++--------------------------------------------+-- EnumDescriptorProto module creation+--------------------------------------------+++fqName :: ProtoName -> String+fqName (ProtoName a b c) = dotPre a (dotPre b c)++enumModule :: String -> D.EnumDescriptorProto -> HsModule+enumModule prefix+           e@(D.EnumDescriptorProto.EnumDescriptorProto+              { D.EnumDescriptorProto.name = Just rawName})+    = let protoName = case splitMod rawName of+                        Left (m,b) -> ProtoName prefix (U.toString m) (U.toString b)+                        Right b    -> ProtoName prefix ""             (U.toString b)+      in HsModule src (Module (fqName protoName))+                  (Just [HsEThingAll (UnQual (HsIdent (baseName protoName)))])+                  standardImports (enumDecls protoName e)++enumValues :: D.EnumDescriptorProto -> [(Integer,HsName)]+enumValues (D.EnumDescriptorProto.EnumDescriptorProto+            { D.EnumDescriptorProto.value = value}) +    = sort $ F.foldr ((:) . oneValue) [] value+  where oneValue  :: D.EnumValueDescriptorProto -> (Integer,HsName)+        oneValue (D.EnumValueDescriptorProto.EnumValueDescriptorProto+                  { D.EnumValueDescriptorProto.name = Just name+                  , D.EnumValueDescriptorProto.number = Just number })+            = (toInteger number,ident name)+      +enumX :: D.EnumDescriptorProto -> HsDecl+enumX e@(D.EnumDescriptorProto.EnumDescriptorProto+         { D.EnumDescriptorProto.name = Just rawName})+    = HsDataDecl src DataType [] (base rawName) [] (map enumValueX values) derives+        where values = enumValues e+              enumValueX :: (Integer,HsName) -> HsQualConDecl+              enumValueX (_,hsName) = HsQualConDecl src [] [] (HsConDecl hsName [])++enumDecls :: ProtoName -> D.EnumDescriptorProto -> [HsDecl]+enumDecls p e = enumX e :  [ instanceMergeableEnum e+                           , instanceBounded e+                           , instanceDefaultEnum e+                           , instanceEnum e+                           , instanceWireEnum e+                           , instanceReflectEnum p e ]++instanceBounded :: D.EnumDescriptorProto -> HsDecl+instanceBounded e@(D.EnumDescriptorProto.EnumDescriptorProto+                   { D.EnumDescriptorProto.name = Just name})+    = HsInstDecl src [] (private "Bounded") [HsTyCon (unqual name)] +                 (map (HsInsDecl . HsFunBind) [set "minBound" (head values)+                                              ,set "maxBound" (last values)]) where+        values = enumValues e+        set f (_,n) = [HsMatch src (HsIdent f) [] (HsUnGuardedRhs (HsCon (UnQual n))) noWhere]++instanceEnum :: D.EnumDescriptorProto -> HsDecl+instanceEnum e@(D.EnumDescriptorProto.EnumDescriptorProto+                { D.EnumDescriptorProto.name = Just name})+    = HsInstDecl src [] (private "Enum") [HsTyCon (unqual name)] +                 (map (HsInsDecl . HsFunBind) [fromEnum',toEnum',succ',pred']) where+        values = enumValues e+        fromEnum' = map fromEnum'one values+        fromEnum'one (v,n) = HsMatch src (HsIdent "fromEnum") [HsPApp (UnQual n) []]+                               (HsUnGuardedRhs (HsLit (HsInt v))) noWhere+        toEnum' = map toEnum'one values+        toEnum'one (v,n) = HsMatch src (HsIdent "toEnum") [HsPLit (HsInt v)]+                               (HsUnGuardedRhs (HsCon (UnQual n))) noWhere+        succ' = zipWith (equate "succ") values (tail values)+        pred' = zipWith (equate "pred") (tail values) values+        equate f (_,n1) (_,n2) = HsMatch src (HsIdent f) [HsPApp (UnQual n1) []]+                                   (HsUnGuardedRhs (HsCon (UnQual n2))) noWhere++-- fromEnum TYPE_ENUM == 14 :: Int+instanceWireEnum :: D.EnumDescriptorProto -> HsDecl+instanceWireEnum (D.EnumDescriptorProto.EnumDescriptorProto+                  { D.EnumDescriptorProto.name = Just name })+    = HsInstDecl src [] (private "Wire") [HsTyCon (unqual name)]+      [ withName "wireSize", withName "wirePut", withGet ]+  where withName foo = HsInsDecl (HsFunBind [HsMatch src (HsIdent foo) [HsPLit (HsInt 14),HsPVar (HsIdent "enum")]+                                          (HsUnGuardedRhs rhs) noWhere])+          where rhs = (pvar foo $$ HsLit (HsInt 14)) $$+                      (HsParen $ pvar "fromEnum" $$ lvar "enum")+        withGet = HsInsDecl (HsFunBind [HsMatch src (HsIdent "wireGet") [HsPLit (HsInt 14)]+                                          (HsUnGuardedRhs rhs) noWhere])+          where rhs = (pvar "fmap" $$ pvar "toEnum") $$+                      (HsParen $ pvar "wireGet" $$ HsLit (HsInt 14))++instanceMergeableEnum :: D.EnumDescriptorProto -> HsDecl+instanceMergeableEnum (D.EnumDescriptorProto.EnumDescriptorProto+                       { D.EnumDescriptorProto.name = Just name }) =+    HsInstDecl src [] (private "Mergeable") [HsTyCon (unqual name)] []++{- from google's descriptor.h, about line 346:++  // Get the field default value if cpp_type() == CPPTYPE_ENUM.  If no+  // explicit default was defined, the default is the first value defined+  // in the enum type (all enum types are required to have at least one value).+  // This never returns NULL.++-}++instanceDefaultEnum :: D.EnumDescriptorProto -> HsDecl+instanceDefaultEnum (D.EnumDescriptorProto.EnumDescriptorProto+                     { D.EnumDescriptorProto.name = Just name+                     , D.EnumDescriptorProto.value = value})+    = HsInstDecl src [] (private "Default") [HsTyCon (unqual name)]+      [ HsInsDecl (HsFunBind [HsMatch src (HsIdent "defaultValue") [] +                                          (HsUnGuardedRhs firstValue) noWhere])+      ]+  where firstValue :: HsExp+        firstValue = case viewl value of+                       (:<) (D.EnumValueDescriptorProto.EnumValueDescriptorProto+                             { D.EnumValueDescriptorProto.name = Just name }) _ ->+                                 HsCon (UnQual (ident name))+                       EmptyL -> error "EnumDescriptorProto had empty sequence of EnumValueDescriptorProto"++instanceReflectEnum :: ProtoName -> D.EnumDescriptorProto -> HsDecl+instanceReflectEnum protoName@(ProtoName a b c)+                    e@(D.EnumDescriptorProto.EnumDescriptorProto+                       { D.EnumDescriptorProto.name = Just rawName })+    = HsInstDecl src [] (private "ReflectEnum") [HsTyCon (unqual rawName)]+      [ HsInsDecl (HsFunBind [HsMatch src (HsIdent "reflectEnum") [] +                                          (HsUnGuardedRhs ascList) noWhere])+      , HsInsDecl (HsFunBind [HsMatch src (HsIdent "reflectEnumInfo") [ HsPWildCard ] +                                          (HsUnGuardedRhs ei) noWhere])+      ]+  where values = enumValues e+        ascList,ei,protoNameExp :: HsExp+        ascList = HsList (map one values)+          where one (v,n@(HsIdent ns)) = HsTuple [HsLit (HsInt v),HsLit (HsString ns),HsCon (UnQual n)]+        ei = foldl' HsApp (HsCon (private "EnumInfo")) [protoNameExp,HsList (map two values)]+          where two (v,n@(HsIdent ns)) = HsTuple [HsLit (HsInt v),HsLit (HsString ns)]+        protoNameExp = HsParen $ foldl' HsApp (HsCon (private "ProtoName")) [HsLit (HsString a)+                                                                            ,HsLit (HsString b)+                                                                            ,HsLit (HsString c)]++--------------------------------------------+-- DescriptorProto module creation is unfinished+--   There are difficult namespace issues+--------------------------------------------++descriptorModule :: String -> D.DescriptorProto -> HsModule+descriptorModule prefix+                 d@(D.DescriptorProto.DescriptorProto+                    { D.DescriptorProto.name = Just rawName+                    , D.DescriptorProto.field = field })+    = let self = UnQual . HsIdent . U.toString . either snd id . splitMod $ rawName+          fqModuleName = Module (dotPre prefix (U.toString rawName))+          imports = standardImports ++ map formatImport (toImport d)+          protoName = case splitMod rawName of+                        Left (m,b) -> ProtoName prefix (U.toString m) (U.toString b)+                        Right b    -> ProtoName prefix ""             (U.toString b)+          (insts,di) = instancesDescriptor protoName d+      in HsModule src fqModuleName (Just [HsEThingAll self]) imports (descriptorX d : insts)+  where formatImport (Left (m,t)) = HsImportDecl src (Module (dotPre prefix (dotPre m t))) True+                                      (Just (Module m)) (Just (False,[HsIAbs (HsIdent t)]))+        formatImport (Right t)    = HsImportDecl src (Module (dotPre prefix t)) False+                                      Nothing (Just (False,[HsIAbs (HsIdent t)]))++standardImports = [ HsImportDecl src (Module "Prelude") False Nothing+                      (Just (False,[HsIVar (HsSymbol "+"),HsIVar (HsSymbol "++")]))+                  , HsImportDecl src (Module "Prelude") True (Just (Module "P'")) Nothing+                  , HsImportDecl src (Module "Text.ProtocolBuffers.Header") True (Just (Module "P'")) Nothing ]++-- Create a list of (Module,Name) to import+-- Assumes that all self references are _not_ qualified!+toImport :: D.DescriptorProto -> [Either (String,String) String]+toImport (D.DescriptorProto.DescriptorProto+          { D.DescriptorProto.name = Just name+          , D.DescriptorProto.field = field })+    = map head . group . sort+      . map (either (\(m,t) -> Left (U.toString m,U.toString t)) (Right . U.toString))+      . map splitMod+      . filter (selfName /=)+      . catMaybes +      . F.foldr ((:) . mayImport) [] $+        field+  where selfName = either snd id (splitMod name)+        mayImport (D.FieldDescriptorProto.FieldDescriptorProto+                   { D.FieldDescriptorProto.type' = type'+                   , D.FieldDescriptorProto.type_name = type_name })+            = answer+          where answer     = maybe answerName checkType type'+                checkType  = maybe answerName (const Nothing) . useType+                answerName = maybe (error "No Name for Type!") Just type_name+ -- data HsConDecl = HsConDecl HsName [HsBangType] -- ^ ordinary data constructor --                | HsRecDecl HsName [([HsName],HsBangType)] -- ^ record constructor fieldX :: D.FieldDescriptorProto -> ([HsName],HsBangType)@@ -114,8 +388,7 @@          { D.FieldDescriptorProto.name = Just name          , D.FieldDescriptorProto.label = Just labelEnum          , D.FieldDescriptorProto.type' = type'-         , D.FieldDescriptorProto.type_name = type_name-         })+         , D.FieldDescriptorProto.type_name = type_name })     = ([ident name],HsUnBangedTy (labeled (HsTyCon typed)))   where labeled = case labelEnum of                     LABEL_OPTIONAL -> typeApp "Maybe"@@ -125,7 +398,7 @@         typed         = maybe typedByName typePrimitive type'         typedByName   = maybe (error "No Name for Type!") qual type_name         typePrimitive :: Type -> HsQName-        typePrimitive = maybe typedByName (UnQual . HsIdent) . useType+        typePrimitive = maybe typedByName private . useType  -- HsDataDecl     SrcLoc DataOrNew HsContext HsName [HsName] [HsQualConDecl] [HsQName] -- data HsQualConDecl = HsQualConDecl SrcLoc {-forall-} [HsTyVarBind] {- . -} HsContext {- => -} HsConDecl@@ -134,14 +407,195 @@ descriptorX :: D.DescriptorProto -> HsDecl descriptorX (D.DescriptorProto.DescriptorProto               { D.DescriptorProto.name = Just name-              , D.DescriptorProto.field = field-              })-    = HsDataDecl src DataType [] (ident name) [] [con] derives-        where con = HsQualConDecl src [] [] (HsRecDecl (ident name) fields)+              , D.DescriptorProto.field = field })+    = HsDataDecl src DataType [] (base name) [] [con] derives+        where con = HsQualConDecl src [] [] (HsRecDecl (base name) fields)                   where fields = F.foldr ((:) . fieldX) [] field +-- There is some confusing code below.  The FieldInfo and+-- DescriptorInfo are getting built as a "side effect" of+-- instanceDefault generating the instances for the Default class.+-- This DescriptorInfo information is then passed to+-- instanceReflectDescriptor to generate the instance of the+-- ReflectDescriptor class.++-- | HsInstDecl     SrcLoc HsContext HsQName [HsType] [HsInstDecl]+instancesDescriptor :: ProtoName -> D.DescriptorProto -> ([HsDecl],DescriptorInfo)+instancesDescriptor protoName d = ([ instanceMergeable d, def, instanceWireDescriptor di, instanceReflectDescriptor di ],di)+  where (def,di) = instanceDefault protoName d++instanceReflectDescriptor :: DescriptorInfo -> HsDecl+instanceReflectDescriptor di+    = HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+        [ HsInsDecl (HsFunBind [HsMatch src (HsIdent "reflectDescriptorInfo") [ HsPWildCard ] +                                            (HsUnGuardedRhs rdi) noWhere]) ]+  where -- massive shortcut through show and read+        rdi :: HsExp+        rdi = pvar "read" $$ HsLit (HsString (show di))++instanceDefault :: ProtoName -> D.DescriptorProto -> (HsDecl,DescriptorInfo)+instanceDefault protoName (D.DescriptorProto.DescriptorProto+                           { D.DescriptorProto.name = Just name+                           , D.DescriptorProto.field = field })+    = ( HsInstDecl src [] (private "Default") [HsTyCon (unqual name)]+          [ HsInsDecl (HsFunBind [HsMatch src (HsIdent "defaultValue") [] +                                          (HsUnGuardedRhs (foldl' HsApp (HsCon (unqual name)) deflist))+                                  noWhere])]+      , descriptorInfo )+  where len = Seq.length field+        old =  (replicate len (HsCon (private "defaultValue")))+        fieldInfos :: [FieldInfo]+        (deflist,fieldInfos) = unzip (F.foldr ((:) . defX) [] field)+        descriptorInfo = DescriptorInfo protoName (Seq.fromList fieldInfos)++defaultValueExp :: D.FieldDescriptorProto -> (HsExp,FieldInfo)+defaultValueExp  d@(D.FieldDescriptorProto.FieldDescriptorProto+                     { D.FieldDescriptorProto.name = Just rawName+                     , D.FieldDescriptorProto.number = Just number+                     , D.FieldDescriptorProto.label = Just label+                     , D.FieldDescriptorProto.type' = Just type'+                     , D.FieldDescriptorProto.type_name = mayTypeName+                     , D.FieldDescriptorProto.default_value = mayRawDef })+    = ( maybe (HsCon (private "defaultValue")) (HsParen . toSyntax) mayDef+      , fieldInfo )+  where toSyntax :: HsDefault -> HsExp+        toSyntax x = case x of+                       HsDef'Bool b -> HsCon (private (show b))+                       HsDef'ByteString bs -> pvar "pack" $$ HsLit (HsString (BSC.unpack bs))+                       HsDef'Rational r -> HsLit (HsFrac r)+                       HsDef'Integer i -> HsLit (HsInt i)+        mayDef = parseDefaultValue d+        fieldInfo = let fieldId = (FieldId (fromIntegral number))+                        fieldType = (FieldType (fromEnum type'))+                        wireTag = toWireTag fieldId fieldType+                        wireTagLength = size'Varint (getWireTag wireTag)+                    in FieldInfo (U.toString rawName) fieldId wireTag wireTagLength+                                 (label == LABEL_REQUIRED) (label == LABEL_REPEATED)+                                 fieldType+                                 (fmap U.toString mayTypeName) mayRawDef mayDef++-- "Nothing" means no value specified+-- A failure to parse a provided value will result in an error at the moment+parseDefaultValue :: D.FieldDescriptorProto -> Maybe HsDefault+parseDefaultValue d@(D.FieldDescriptorProto.FieldDescriptorProto+                     { D.FieldDescriptorProto.type' = type'+                     , D.FieldDescriptorProto.default_value = mayDef })+    = do bs <- mayDef+         t <- type'+         todo <- case t of+                   TYPE_MESSAGE -> Nothing+                   TYPE_ENUM    -> Nothing+                   TYPE_GROUP   -> error "<TYPE_GROUP IS UNIMPLEMENTED>"+                   TYPE_BOOL    -> return parseDefBool+                   TYPE_BYTES   -> return parseDefBytes+                   TYPE_DOUBLE  -> return parseDefDouble+                   TYPE_FLOAT   -> return parseDefFloat+                   TYPE_STRING  -> return parseDefString+                   _            -> return parseDefInteger+         case todo bs of+           Nothing -> error ("Could not parse the default value for "++show d)+           Just value -> return value++defX :: D.FieldDescriptorProto -> (HsExp,FieldInfo)+defX d@(D.FieldDescriptorProto.FieldDescriptorProto+         { D.FieldDescriptorProto.name = Just name+         , D.FieldDescriptorProto.label = Just labelEnum+         , D.FieldDescriptorProto.type' = type'+         , D.FieldDescriptorProto.type_name = type_name })+    =  ( HsParen $ case labelEnum of LABEL_OPTIONAL -> HsCon (private "Just") $$ dv+                                     _ -> dv+       , fi )+  where (dv,fi) = defaultValueExp d++instanceMergeable :: D.DescriptorProto -> HsDecl+instanceMergeable (D.DescriptorProto.DescriptorProto+              { D.DescriptorProto.name = Just name+              , D.DescriptorProto.field = field })+    = HsInstDecl src [] (private "Mergeable") [HsTyCon (unqual name)]+        [ HsInsDecl (HsFunBind [HsMatch src (HsIdent "mergeEmpty") [] +                                (HsUnGuardedRhs (foldl' HsApp (HsCon (unqual name)) +                                                              (replicate len (HsCon (private "mergeEmpty")))))+                                noWhere])+        , HsInsDecl (HsFunBind [HsMatch src (HsIdent "mergeAppend") [ HsPApp (unqual name) patternVars1+                                                                    , HsPApp (unqual name) patternVars2]+                                (HsUnGuardedRhs (foldl' HsApp (HsCon (unqual name)) +                                                              (zipWith append vars1 vars2)))+                                 noWhere])+        ]+  where len = Seq.length field+        con = HsCon (qual name)+        patternVars1 :: [HsPat]+        patternVars1 = take len inf+            where inf = map (\n -> HsPVar (HsIdent ("x'" ++ show n))) [1..]+        patternVars2 :: [HsPat]+        patternVars2 = take len inf+            where inf = map (\n -> HsPVar (HsIdent ("y'" ++ show n))) [1..]+        vars1 :: [HsExp]+        vars1 = take len inf+            where inf = map (\n -> lvar ("x'" ++ show n)) [1..]+        vars2 :: [HsExp]+        vars2 = take len inf+            where inf = map (\n -> lvar ("y'" ++ show n)) [1..]+        append x y = HsParen $ pvar "mergeAppend" $$ x $$ y++instanceWireDescriptor :: DescriptorInfo -> HsDecl+instanceWireDescriptor (DescriptorInfo { descName = protoName+                                       , fields = fieldInfos })+  = let myP11 = HsPLit (HsInt 11)+        my11 = HsLit (HsInt 11)+        me = UnQual (HsIdent (baseName protoName))+        mine = HsPApp me . take (Seq.length fieldInfos) . map (\n -> HsPVar (HsIdent ("x'" ++ show n))) $ [1..]+        vars = take (Seq.length fieldInfos) . map (\n -> lvar ("x'" ++ show n)) $ [1..]+        add a b = HsInfixApp a (HsQVarOp (UnQual (HsSymbol "+"))) b+        sizes =  zipWith toSize vars . F.toList $ fieldInfos+        toSize var fi = let f = if isRequired fi then "wireSizeReq"+                                  else if canRepeat fi then "wireSizeRep"+                                      else "wireSizeOpt"+                        in foldl' HsApp (pvar f) [ HsLit (HsInt (toInteger (wireTagLength fi)))+                                                 , HsLit (HsInt (toInteger (getFieldType (typeCode fi))))+                                                 , var]+        putStmts = zipWith toPut vars . F.toList $ fieldInfos+        toPut var fi = let f = if isRequired fi then "wirePutReq"+                                 else if canRepeat fi then "wirePutRep"+                                     else "wirePutOpt"+                       in HsQualifier $+                          foldl' HsApp (pvar f) [ HsLit (HsInt (toInteger (getWireTag (wireTag fi))))+                                                , HsLit (HsInt (toInteger (getFieldType (typeCode fi))))+                                                , var]+        whereUpdateSelf = HsBDecls [HsFunBind [HsMatch src (HsIdent "update'Self")+                            [HsPVar (HsIdent "field'Number") ,HsPVar (HsIdent "old'Self")]+                            (HsUnGuardedRhs (HsCase (lvar "field'Number") updateAlts)) noWhere]]+        updateAlts = map toUpdate (F.toList fieldInfos) ++ [HsAlt src HsPWildCard (HsUnGuardedAlt $+                       pvar "unknownField" $$ (lvar "field'Number")) noWhere]+        toUpdate fi = HsAlt src (HsPLit . HsInt . toInteger . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $ +                        pvar "fmap" $$ (HsParen $ HsLambda src [HsPVar (HsIdent "new'Field")] $+                                          HsRecUpdate (lvar "old'Self") [HsFieldUpdate (UnQual . HsIdent . fieldName $ fi)+                                                                                       (labelUpdate fi)])+                                    $$ (HsParen (pvar "wireGet" $$ (HsLit . HsInt . toInteger . getFieldType . typeCode $ fi)))) noWhere+        labelUpdate fi | isRequired fi = lvar "new'Field"+                       | canRepeat fi = pvar "append" $$ HsParen ((lvar . fieldName $ fi) $$ lvar "old'Self")+                                                      $$ lvar "new'Field"+                       | otherwise = HsCon (private "Just") $$ lvar "new'Field"++    in HsInstDecl src [] (private "Wire") [HsTyCon me]+        [ HsInsDecl (HsFunBind [HsMatch src (HsIdent "wireSize") [myP11,mine] (HsUnGuardedRhs $+                                  (pvar "lenSize" $$ HsParen (foldl' add (HsLit (HsInt 0)) sizes))) noWhere])+        , HsInsDecl (HsFunBind [HsMatch src (HsIdent "wirePut") [myP11,HsPAsPat (HsIdent "self'") (HsPParen mine)] (HsUnGuardedRhs $+                                  (HsDo ((:) (HsQualifier $+                                              pvar "putSize" $$+                                                (HsParen $ foldl' HsApp (pvar "wireSize") [ my11+                                                                                          , lvar "self'"]))+                                             putStmts))) noWhere])+        , HsInsDecl (HsFunBind [HsMatch src (HsIdent "wireGet") [myP11] (HsUnGuardedRhs $+                                  (pvar "getMessage" $$ lvar "update'Self")+                                  ) whereUpdateSelf])+                                        +        ]++------------------------------------------------------------------+ derives :: [HsQName]-derives = map (UnQual . HsIdent) ["Show","Eq","Ord","Data","Typeable"]+derives = map private ["Show","Read","Eq","Ord","Data","Typeable"]  useType :: Type -> Maybe String useType TYPE_DOUBLE   = Just "Double"@@ -162,3 +616,137 @@ useType TYPE_MESSAGE  = Nothing useType TYPE_ENUM     = Nothing useType TYPE_GROUP    = error "<TYPE_GROUP IS UNIMPLEMENTED>"++noWhere = (HsBDecls [])++test = putStrLn . prettyPrint . descriptorModule "Text" $ d++testDesc =  putStrLn . prettyPrint . descriptorModule "Text" $ genFieldOptions++testLabel = putStrLn . prettyPrint $ enumModule "Text" labelTest+testType = putStrLn . prettyPrint $ enumModule "Text" t++-- try and generate a small replacement for my manual file+genFieldOptions :: D.DescriptorProto.DescriptorProto+genFieldOptions =+  defaultValue+  { D.DescriptorProto.name = Just (BSC.pack "DescriptorProtos.FieldOptions") +  , D.DescriptorProto.field = Seq.fromList+    [ defaultValue+      { D.FieldDescriptorProto.name = Just (BSC.pack "ctype")+      , D.FieldDescriptorProto.number = Just 1+      , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+      , D.FieldDescriptorProto.type' = Just TYPE_ENUM+      , D.FieldDescriptorProto.type_name = Just (BSC.pack "DescriptorProtos.FieldOptions.CType")+      , D.FieldDescriptorProto.default_value = Nothing+      }+    , defaultValue+      { D.FieldDescriptorProto.name = Just (BSC.pack "experimental_map_key")+      , D.FieldDescriptorProto.number = Just 9+      , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+      , D.FieldDescriptorProto.type' = Just TYPE_STRING+      , D.FieldDescriptorProto.default_value = Nothing+      }+    ]+  }++-- test several features+d :: D.DescriptorProto.DescriptorProto+d = defaultValue+    { D.DescriptorProto.name = Just (BSC.pack "SomeMod.ServiceOptions") +    , D.DescriptorProto.field = Seq.fromList+       [ defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "fieldString")+         , D.FieldDescriptorProto.number = Just 1+         , D.FieldDescriptorProto.label = Just LABEL_REQUIRED+         , D.FieldDescriptorProto.type' = Just TYPE_STRING+         , D.FieldDescriptorProto.default_value = Just (BSC.pack "Hello World")+         }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "fieldDouble")+         , D.FieldDescriptorProto.number = Just 4+         , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+         , D.FieldDescriptorProto.type' = Just TYPE_DOUBLE+         , D.FieldDescriptorProto.default_value = Just (BSC.pack "+5.5e-10")+        }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "fieldBytes")+         , D.FieldDescriptorProto.number = Just 2+         , D.FieldDescriptorProto.label = Just LABEL_REQUIRED+         , D.FieldDescriptorProto.type' = Just TYPE_STRING+         , D.FieldDescriptorProto.default_value = Just (BSC.pack . cEncode $ [0,5..255])+        }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "fieldInt64")+         , D.FieldDescriptorProto.number = Just 3+         , D.FieldDescriptorProto.label = Just LABEL_REQUIRED+         , D.FieldDescriptorProto.type' = Just TYPE_INT64+         , D.FieldDescriptorProto.default_value = Just (BSC.pack "-0x40")+        }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "fieldBool")+         , D.FieldDescriptorProto.number = Just 5+         , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+         , D.FieldDescriptorProto.type' = Just TYPE_STRING+         , D.FieldDescriptorProto.default_value = Just (BSC.pack "False")+        }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "field2TestSelf")+         , D.FieldDescriptorProto.number = Just 6+         , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+         , D.FieldDescriptorProto.type' = Just TYPE_MESSAGE+         , D.FieldDescriptorProto.type_name = Just (BSC.pack "ServiceOptions")+         }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "field3TestQualified")+         , D.FieldDescriptorProto.number = Just 7+         , D.FieldDescriptorProto.label = Just LABEL_REPEATED+         , D.FieldDescriptorProto.type' = Just TYPE_MESSAGE+         , D.FieldDescriptorProto.type_name = Just (BSC.pack "A.B.C.Label")+         }+       , defaultValue+         { D.FieldDescriptorProto.name = Just (BSC.pack "field4TestUnqualified")+         , D.FieldDescriptorProto.number = Just 8+         , D.FieldDescriptorProto.label = Just LABEL_REPEATED+         , D.FieldDescriptorProto.type' = Just TYPE_MESSAGE+         , D.FieldDescriptorProto.type_name = Just (BSC.pack "Maybe")+         }+       ]+    }++labelTest :: D.EnumDescriptorProto.EnumDescriptorProto+labelTest = defaultValue+    { D.EnumDescriptorProto.name = Just (BSC.pack "DescriptorProtos.FieldDescriptorProto.Label")+    , D.EnumDescriptorProto.value = Seq.fromList+      [ defaultValue { D.EnumValueDescriptorProto.name = Just (BSC.pack "LABEL_OPTIONAL")+                     , D.EnumValueDescriptorProto.number = Just 1 }+      , defaultValue { D.EnumValueDescriptorProto.name = Just (BSC.pack "LABEL_REQUIRED")+                     , D.EnumValueDescriptorProto.number = Just 2 }+      , defaultValue { D.EnumValueDescriptorProto.name = Just (BSC.pack "LABEL_REPEATED")+                     , D.EnumValueDescriptorProto.number = Just 3 }+      ]+    }++t :: D.EnumDescriptorProto.EnumDescriptorProto+t = defaultValue { D.EnumDescriptorProto.name = Just (BSC.pack "DescriptorProtos.FieldDescriptorProto.Type")+                 , D.EnumDescriptorProto.value = Seq.fromList . zipWith make [1..] $ names }+  where make :: Int32 -> String -> D.EnumValueDescriptorProto+        make i s = defaultValue { D.EnumValueDescriptorProto.name = Just (BSC.pack s)+                                , D.EnumValueDescriptorProto.number = Just i }+        names = ["TYPE_DOUBLE","TYPE_FLOAT","TYPE_INT64","TYPE_UINT64","TYPE_INT32"+                ,"TYPE_FIXED64","TYPE_FIXED32","TYPE_BOOL","TYPE_STRING","TYPE_GROUP"+                ,"TYPE_MESSAGE","TYPE_BYTES","TYPE_UINT32","TYPE_ENUM","TYPE_SFIXED32"+                ,"TYPE_SFIXED64","TYPE_SINT32","TYPE_SINT64"]+++ {-+-- http://haskell.org/onlinereport/lexemes.html#sect2.4+-- The .proto parser should have handled this+mangle :: String -> String+mangle s = fromMaybe s (M.lookup s m)+  where m = M.fromAscList . map (\t -> (t,t++"'") $ reserved+        reserved = ["case","class","data","default","deriving","do","else"+                   ,"if","import","in","infix","infixl","infixr","instance"+                   ,"let","module","newtype","of","then","type","where"]+-}+
+ Text/ProtocolBuffers/Get.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances+  , TypeSynonymInstances, PatternGuards #-}+module Get where++--import Text.ProtocolBuffers.Basic+import Data.ByteString.Lazy(ByteString,empty)+import Data.ByteString.Lazy.Char8(pack)+import Data.Sequence(Seq,empty,null)++data Message = Message { number :: Int+                       , name :: Maybe ByteString -- [ default "Curry" ] in proto file+                       , children :: Seq Message+                       , parent :: Maybe Message }+  deriving (Show)++class Default a where defaultValue :: a++class Default a => MessageGetter a b c | a b -> c where+   get :: (a -> b) -> a -> c+   isSet :: (a->b) -> a -> Bool+   isSet _ _ = True -- simplifies all required base types++--When the proto file gives default values put them in this instance+instance Default Message where+    defaultValue = Message defaultValue+                           (Just (pack "Curry"))+                           defaultValue+                           defaultValue++instance Default a => Default (Maybe a) where defaultValue = Just defaultValue+instance Default (Seq a) where defaultValue = Data.Sequence.empty+instance Default ByteString where defaultValue = Data.ByteString.empty+instance Default Int where defaultValue = 0+-- etc for all base type++instance MessageGetter Message (Maybe a) a where+   get f m | Just v <- f m = v+           | Just v <- f defaultValue = v+           | otherwise = error "Impossible case of get happened"+   isSet f m = maybe False (const True) (f m)+instance MessageGetter Message (Seq a) (Seq a) where+   get = ($)+   isSet f m = not (Data.Sequence.null (f m))+instance MessageGetter Message Int Int where get = ($)+instance MessageGetter Message ByteString ByteString where get = ($)+-- etc for all base types
Text/ProtocolBuffers/Header.hs view
@@ -1,38 +1,53 @@-module Text.ProtocolBuffers.Header (-    UArray,-    ByteString,-    Data(..),-    Int32,-    Int64,Seq,-    Typeable(..),-    Word32,-    Word64-  ,module Text.ProtocolBuffers.Default-  ,module Data.Monoid-  ,module Data.DeriveTH-  ,module Text.ProtocolBuffers.Mergeable-  ,module Text.ProtocolBuffers.DeriveMergeable) where+-- This provides much that is needed for the output of Gen.hs to compile against.+-- It will be imported qualified as P'+-- The prime ensuring no name conflicts are possible.+module Text.ProtocolBuffers.Header+    ( -- needed for Gen.hs output+      emptyBS+    , pack+    , append+    , module Control.Monad+    , module Data.Generics+    , module Data.Typeable+    , module Text.ProtocolBuffers.Basic+    , module Text.ProtocolBuffers.Default+    , module Text.ProtocolBuffers.Mergeable+    , module Text.ProtocolBuffers.Reflections+    , module Text.ProtocolBuffers.WireMessage+    -- deprecated below+    , module Data.Monoid+    , module Data.DeriveTH+    , module Text.ProtocolBuffers.DeriveMergeable+    ) where -import Data.Array.Unboxed(UArray)-import Data.ByteString(ByteString)-import Data.DeriveTH+import Control.Monad(ap)+import Data.ByteString.Lazy(empty)+import Data.ByteString.Lazy.Char8(pack)+import Data.Dynamic(Dynamic) import Data.Generics(Data(..))-import Data.Int(Int32,Int64) import Data.Monoid(Monoid(..))-import Data.Sequence(Seq) import Data.Typeable(Typeable(..))-import Data.Word(Word32,Word64) -import Text.ProtocolBuffers.Default-import Text.ProtocolBuffers.DeriveMergeable-import Text.ProtocolBuffers.Mergeable+import Text.ProtocolBuffers.Basic -- all+import Text.ProtocolBuffers.Default(Default(..))+import Text.ProtocolBuffers.Mergeable(Mergeable(..))+import Text.ProtocolBuffers.Reflections(ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..))+import Text.ProtocolBuffers.WireMessage(Wire(..)+                                       , size,lenSize,putSize+                                       , wireSizeReq,wireSizeOpt,wireSizeRep+                                       , wirePutReq,wirePutOpt,wirePutRep+                                       , getMessage,getBareMessage+                                       , unknownField)+import Data.Sequence((|>)) -{----instance OptionFlag a => Monoid (Option a (UArray i e)) where mempty = Absent; mappend = op'Last-instance OptionFlag a => Monoid (Option a Bool) where mempty = Absent; mappend = op'Last-instance OptionFlag a => Monoid (Option a ByteString) where mempty = Absent; mappend = op'Last-instance OptionFlag a => Monoid (Option a Int32) where mempty = Absent; mappend = op'Last-instance OptionFlag a => Monoid (Option a Int64) where mempty = Absent; mappend = op'Last-instance OptionFlag a => Monoid (Option a Word32) where mempty = Absent; mappend = op'Last-instance OptionFlag a => Monoid (Option a Word64) where mempty = Absent; mappend = op'Last--}+-- deprecated imports+import Data.DeriveTH+import Text.ProtocolBuffers.DeriveMergeable(makeMergeable,makeMergeableEnum)+++append :: Seq a -> a -> Seq a+append = (|>)++emptyBS :: ByteString+emptyBS = Data.ByteString.Lazy.empty+
Text/ProtocolBuffers/Instances.hs view
@@ -1,7 +1,8 @@-module Text.ProtocolBuffers.Instances(showsType,parseType) where+module Text.ProtocolBuffers.Instances(showsType,parseType,showsLabel,parseLabel) where  import Text.ParserCombinators.ReadP import Text.DescriptorProtos.FieldDescriptorProto.Type(Type(..))+import Text.DescriptorProtos.FieldDescriptorProto.Label(Label(..))  {- instance Show Type where@@ -11,6 +12,11 @@   readsPrec _ = readP_to_S readType -} +showsLabel :: Label -> ShowS+showsLabel LABEL_OPTIONAL s = "optional" ++ s+showsLabel LABEL_REQUIRED s = "required" ++ s+showsLabel LABEL_REPEATED s = "repeated" ++ s+ showsType :: Type -> ShowS showsType TYPE_DOUBLE s = "double" ++ s showsType TYPE_FLOAT s = "float" ++ s@@ -36,6 +42,17 @@                 [(val,[])] -> Just val                 _ -> Nothing +parseLabel :: String -> Maybe Label+parseLabel s = case readP_to_S readLabel s of+                [(val,[])] -> Just val+                _ -> Nothing++readLabel :: ReadP Label+readLabel = choice [ return LABEL_OPTIONAL << string "optional"+                   , return LABEL_REQUIRED << string "required"+                   , return LABEL_REPEATED << string "repeated"+                   ]+ readType :: ReadP Type readType = choice [ return TYPE_DOUBLE << string "double"                   , return TYPE_FLOAT << string "float"@@ -56,5 +73,7 @@                   , return TYPE_SINT32 << string "sint32"                   , return TYPE_SINT64 << string "sint64"                   ]-  where (<<) = flip (>>)++(<<) :: Monad m => m a -> m b -> m a+(<<) = flip (>>)
+ Text/ProtocolBuffers/Lexer.hs view
@@ -0,0 +1,443 @@+{-# OPTIONS -cpp #-}+{-# LINE 1 "Text/ProtocolBuffers/Lexer.x" #-}++module Text.ProtocolBuffers.Lexer (Lexed(..), alexScanTokens,getLinePos)  where++import Control.Monad.Error()+import Codec.Binary.UTF8.String(encode)+import qualified Data.ByteString.Lazy as L+import Data.Char(ord,chr,isHexDigit,isOctDigit,toLower)+import Data.List(sort,unfoldr)+import Data.Word(Word8)+import Numeric(readHex,readOct,readDec,showOct,readSigned,readFloat)+++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++++import qualified Data.ByteString.Lazy.Char8 as ByteString++++-- -----------------------------------------------------------------------------+-- The input type++{-# LINE 29 "templates/wrappers.hs" #-}+++type AlexInput = (AlexPosn, 	-- current position,+		  Char,		-- previous char+		  ByteString.ByteString)	-- current input string++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (p,c,s) = c++alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar (p,_,cs) | ByteString.null cs = Nothing+                     | otherwise = let c   = ByteString.head cs+                                       cs' = ByteString.tail cs+                                       p'  = alexMove p c+                                    in p' `seq` cs' `seq` Just (c, (p', c, cs'))+++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text.  It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.+++data AlexPosn = AlexPn !Int !Int !Int+	deriving (Eq,Show)++alexStartPos :: AlexPosn+alexStartPos = AlexPn 0 1 1++alexMove :: AlexPosn -> Char -> AlexPosn+alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+7) `div` 8)*8+1)+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1+alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)+++-- -----------------------------------------------------------------------------+-- Default monad++{-# LINE 150 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)++{-# LINE 233 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper++{-# LINE 255 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version++{-# LINE 277 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.++{-# LINE 294 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version+++--alexScanTokens :: ByteString -> [token]+alexScanTokens str = go (alexStartPos,'\n',str)+  where go inp@(pos,_,str) =+          case alexScan inp 0 of+                AlexEOF -> []+                AlexError _ -> error "lexical error"+                AlexSkip  inp' len     -> go inp'+                AlexToken inp' len act -> act pos (ByteString.take (fromIntegral len) str) : go inp'++++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.++alex_base :: Array Int Int+alex_base = listArray (0,71) [-8,-3,2,109,6,7,-24,9,10,12,42,46,106,77,108,133,118,170,0,247,269,323,377,0,452,475,536,0,613,623,143,257,345,355,677,0,0,137,327,329,343,800,823,879,344,903,950,972,996,1018,346,330,331,1029,1090,1101,381,1163,1174,1185,1196,1231,537,1259,1336,1413,1490,1567,1625,1683,0,0]++alex_table :: Array Int Int+alex_table = listArray (0,1938) [0,3,2,3,3,3,2,2,2,2,2,2,2,2,2,2,-1,-1,10,-1,-1,0,-1,4,3,0,51,7,0,2,0,39,70,70,2,0,70,16,68,6,20,14,14,14,14,14,14,14,14,14,0,70,-1,70,12,0,-1,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,70,12,70,0,64,12,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,70,-1,70,2,2,2,2,2,31,0,15,15,15,15,15,15,15,15,15,15,0,0,-1,0,0,0,2,0,0,0,0,32,-1,12,0,0,0,0,9,31,0,15,15,15,15,15,15,15,15,15,15,19,13,13,13,13,13,13,13,13,13,36,32,32,31,-1,15,15,15,15,15,15,15,15,15,15,30,30,30,30,30,30,30,30,30,30,0,32,0,0,0,0,0,0,32,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,42,0,0,0,0,32,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,-1,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,31,0,21,21,21,21,21,21,21,21,28,28,29,29,29,29,29,29,29,29,29,29,31,32,21,21,21,21,21,21,21,21,28,28,-1,0,-1,-1,-1,0,0,0,25,0,-1,32,-1,-1,-1,0,-1,-1,0,-1,0,32,0,0,0,0,-1,-1,0,-1,25,0,0,0,36,0,0,36,36,0,25,36,31,32,21,21,21,21,21,21,21,21,28,28,-1,36,36,0,36,0,-1,33,25,33,-1,32,30,30,30,30,30,30,30,30,30,30,30,30,30,30,30,30,30,30,30,30,0,0,36,0,0,0,54,0,42,54,54,32,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,42,42,0,42,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,-1,54,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,24,24,24,24,24,24,24,24,24,24,0,0,0,0,0,0,0,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,0,0,0,0,-1,0,0,24,24,24,24,24,24,-1,-1,0,24,24,24,24,24,24,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,36,24,24,24,24,24,24,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,54,0,-1,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,31,0,28,28,28,28,28,28,28,28,28,28,29,29,29,29,29,29,29,29,29,29,0,32,0,0,0,0,-1,0,0,0,0,32,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32,0,0,0,0,0,0,0,0,0,32,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,-1,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,0,0,-1,0,0,0,0,0,0,0,0,0,0,0,0,-1,0,0,0,0,0,0,0,0,0,-1,0,0,0,0,0,36,0,0,0,0,0,0,0,0,43,43,43,43,43,43,43,43,43,43,0,0,0,0,37,0,0,43,43,43,43,43,43,45,46,46,46,46,46,46,46,-1,0,0,0,0,0,0,0,0,0,-1,0,0,42,0,0,0,0,43,43,43,43,43,43,-1,0,0,0,0,0,0,0,41,0,-1,0,42,0,0,36,0,0,0,0,0,0,0,0,44,44,44,44,44,44,44,44,44,44,0,0,0,0,0,36,41,44,44,44,44,44,44,-1,47,47,47,47,47,47,47,47,0,-1,0,0,0,0,0,0,0,0,0,0,42,-1,0,0,0,44,44,44,44,44,44,-1,0,0,0,0,0,0,36,0,0,0,0,0,42,-1,0,48,48,48,48,48,48,48,48,-1,0,0,0,0,36,0,0,0,0,0,0,-1,0,49,49,49,49,49,49,49,49,-1,-1,0,0,0,0,0,36,0,0,0,-1,0,0,42,0,50,50,50,50,50,50,50,50,0,0,0,0,0,36,0,0,0,0,0,36,42,0,50,50,50,50,50,50,50,50,0,0,0,55,55,55,55,55,55,55,55,55,55,0,42,0,-1,0,0,0,55,55,55,55,55,55,-1,-1,0,0,0,0,0,0,0,0,42,-1,0,0,0,0,0,0,0,0,0,54,0,0,38,0,55,55,55,55,55,55,0,0,0,36,0,0,57,58,58,58,58,58,58,58,0,0,0,56,56,56,56,56,56,56,56,56,56,0,0,0,0,-1,0,0,56,56,56,56,56,56,0,-1,-1,0,0,0,53,0,0,0,54,0,-1,-1,0,0,0,0,0,0,0,54,0,-1,-1,36,56,56,56,56,56,56,0,0,-1,0,36,0,53,59,59,59,59,59,59,59,59,36,0,0,60,60,60,60,60,60,60,60,36,-1,0,61,61,61,61,61,61,61,61,-1,0,0,62,62,62,62,62,62,62,62,0,0,0,54,0,0,0,0,0,0,0,0,0,36,54,0,0,0,0,0,0,0,0,0,0,54,0,62,62,62,62,62,62,62,62,0,54,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,69,0,65,65,65,65,65,65,65,65,65,65,0,0,0,0,0,0,54,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,0,0,0,0,65,0,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,69,0,65,65,65,65,65,65,65,65,65,65,0,0,0,0,0,0,0,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,0,0,0,0,65,0,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,69,0,65,65,65,65,65,65,65,65,65,65,0,0,0,0,0,0,0,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,0,0,0,0,65,0,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,65,69,0,67,67,67,67,67,67,67,67,67,67,0,0,0,0,0,0,0,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,0,0,0,0,67,0,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,69,0,67,67,67,67,67,67,67,67,67,67,0,0,0,0,0,0,0,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,0,0,0,0,67,0,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,67,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,0,0,0,0,63,0,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,63,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,0,0,0,0,66,0,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,66,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]++alex_check :: Array Int Int+alex_check = listArray (0,1938) [-1,9,10,11,12,13,9,10,11,12,13,9,10,11,12,13,10,10,42,10,10,-1,10,47,32,-1,34,35,-1,32,-1,39,40,41,32,-1,44,45,46,47,48,49,50,51,52,53,54,55,56,57,-1,59,10,61,42,-1,10,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,42,93,-1,95,42,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,10,125,9,10,11,12,13,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,0,-1,-1,-1,32,-1,-1,-1,-1,69,10,42,-1,-1,-1,-1,47,46,-1,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,56,57,39,69,101,46,10,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,56,57,-1,69,-1,-1,-1,-1,-1,-1,101,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,92,-1,-1,-1,-1,101,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,46,-1,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,56,57,46,69,48,49,50,51,52,53,54,55,56,57,0,-1,0,0,0,-1,-1,-1,88,-1,10,69,10,10,10,-1,0,0,-1,0,-1,101,-1,-1,-1,-1,10,10,-1,10,88,-1,-1,-1,34,-1,-1,34,34,-1,120,39,46,101,48,49,50,51,52,53,54,55,56,57,0,39,39,-1,39,-1,10,43,120,45,10,69,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,56,57,-1,-1,34,-1,-1,-1,92,-1,92,92,92,101,48,49,50,51,52,53,54,55,56,57,92,92,-1,92,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,92,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,0,-1,-1,65,66,67,68,69,70,10,10,-1,97,98,99,100,101,102,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,34,97,98,99,100,101,102,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,92,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,46,-1,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,56,57,-1,69,-1,-1,-1,-1,10,-1,-1,-1,-1,69,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,101,-1,-1,-1,-1,-1,-1,-1,-1,-1,101,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,10,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,10,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,39,-1,-1,65,66,67,68,69,70,48,49,50,51,52,53,54,55,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,10,-1,-1,92,-1,-1,-1,-1,97,98,99,100,101,102,0,-1,-1,-1,-1,-1,-1,-1,88,-1,10,-1,92,-1,-1,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,39,120,65,66,67,68,69,70,0,48,49,50,51,52,53,54,55,-1,10,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,0,-1,-1,-1,97,98,99,100,101,102,10,-1,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,92,0,-1,48,49,50,51,52,53,54,55,10,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,-1,0,-1,48,49,50,51,52,53,54,55,10,0,-1,-1,-1,-1,-1,39,-1,-1,-1,10,-1,-1,92,-1,48,49,50,51,52,53,54,55,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,34,92,-1,48,49,50,51,52,53,54,55,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,92,-1,0,-1,-1,-1,65,66,67,68,69,70,10,0,-1,-1,-1,-1,-1,-1,-1,-1,92,10,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,-1,34,-1,97,98,99,100,101,102,-1,-1,-1,34,-1,-1,48,49,50,51,52,53,54,55,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,0,-1,-1,65,66,67,68,69,70,-1,10,0,-1,-1,-1,88,-1,-1,-1,92,-1,10,0,-1,-1,-1,-1,-1,-1,-1,92,-1,10,0,34,97,98,99,100,101,102,-1,-1,10,-1,34,-1,120,48,49,50,51,52,53,54,55,34,-1,-1,48,49,50,51,52,53,54,55,34,0,-1,48,49,50,51,52,53,54,55,10,-1,-1,48,49,50,51,52,53,54,55,-1,-1,-1,92,-1,-1,-1,-1,-1,-1,-1,-1,-1,34,92,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,48,49,50,51,52,53,54,55,-1,92,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,92,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1]++alex_deflt :: Array Int Int+alex_deflt = listArray (0,71) [71,-1,-1,-1,5,5,-1,8,8,11,11,11,11,-1,-1,-1,-1,18,-1,-1,-1,-1,23,-1,-1,-1,27,-1,-1,-1,-1,-1,-1,-1,35,-1,-1,40,52,40,40,40,40,40,40,40,40,40,40,40,40,52,52,52,52,52,52,52,52,52,52,52,52,-1,-1,-1,-1,-1,-1,-1,-1,-1]++alex_accept = listArray (0::Int,71) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_15))],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[(AlexAccPred  (alex_action_4) (alexRightContext 17)),(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_8))],[(AlexAccPred  (alex_action_4) (alexRightContext 17)),(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_8))],[(AlexAccPred  (alex_action_4) (alexRightContext 17)),(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_15))],[],[(AlexAccSkip)],[(AlexAccPred  (alex_action_5) (alexRightContext 22)),(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_9))],[(AlexAccPred  (alex_action_5) (alexRightContext 22)),(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_9))],[(AlexAccPred  (alex_action_5) (alexRightContext 22)),(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_9))],[],[(AlexAccSkip)],[(AlexAccPred  (alex_action_6) (alexRightContext 26)),(AlexAcc (alex_action_10))],[],[],[(AlexAccSkip)],[(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_11))],[(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_11))],[(AlexAccPred  (alex_action_7) (alexRightContext 34)),(AlexAcc (alex_action_11))],[],[],[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_15))],[],[],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_15))],[],[],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_15))],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_15))]]+{-# LINE 53 "Text/ProtocolBuffers/Lexer.x" #-}++line :: AlexPosn -> Int+line (AlexPn _byte line' _col) = line'+{-# INLINE line #-}++data Lexed = L_Integer !Int !Integer+           | L_Double !Int !Double+           | L_Name !Int !L.ByteString+           | L_String !Int !L.ByteString+           | L !Int !Char+           | L_Error !Int !String+  deriving (Show,Eq)++getLinePos :: Lexed -> Int+getLinePos x = case x of+                 L_Integer i _ -> i+                 L_Double  i _ -> i+                 L_Name    i _ -> i+                 L_String  i _ -> i+                 L         i _ -> i+                 L_Error   i _ -> i++-- 'errAt' is the only access to L_Error, so I can see where it is created with pos+errAt pos msg =  L_Error (line pos) $ "Lexical error (in Text.ProtocolBuffers.Lexer): "++ msg ++ ", at "++see pos where+  see (AlexPn char line col) = "character "++show char++" line "++show line++" column "++show col++"."+dieAt msg pos _s = errAt pos msg+wtfAt pos s = errAt pos $ "unknown character "++show c++" (decimal "++show (ord c)++")"+  where (c:_) = ByteString.unpack s++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++-- Given the regexps above, the "parse* failed" messages should be impossible.+parseDec pos s = maybe (errAt pos "parseDec failed") (L_Integer (line pos)) $ mayRead (readSigned readDec) (ByteString.unpack s)+parseOct pos s = maybe (errAt pos "parseOct failed") (L_Integer (line pos)) $ mayRead (readSigned readOct) (ByteString.unpack s)+parseHex pos s = maybe (errAt pos "parseHex failed") (L_Integer (line pos)) $ mayRead (readSigned (readHex . drop 2)) (ByteString.unpack s)+parseDouble pos s = maybe (errAt pos "parseDouble failed") (L_Double (line pos)) $ mayRead (readSigned readFloat) (ByteString.unpack s)+parseStr pos s = either (errAt pos) (L_String (line pos) . L.pack) $ sDecode . ByteString.unpack $ (ByteString.init (ByteString.tail s))+parseName pos s = L_Name (line pos) s+parseChar pos s = L (line pos) (ByteString.head s)++-- Generalization of concat . unfoldr to monadic-Either form:+op :: ( [Char] -> Either String (Maybe ([Word8],[Char]))) -> [Char] -> Either String [Word8]+op one = go id where+  go f cs = case one cs of+              Left msg -> Left msg+              Right Nothing -> Right (f [])+              Right (Just (ws,cs)) -> go (f . (ws++)) cs++-- Put this mess in the lexer, so the rest of the code can assume+-- everything is saner.  The input is checked to really be "Char8"+-- values in the range [0..255] and to be c-escaped (in order to+-- render binary information printable).  This decodes the c-escaping+-- and returns the binary data as Word8.+-- +-- A decoding error causes (Left msg) to be returned.+sDecode :: [Char] -> Either String [Word8]+sDecode = op one where+  one :: [Char] -> Either String (Maybe ([Word8],[Char]))+  one (x:xs) | x /= '\\' = do x' <- checkChar8 x+                              return $ Just (x',xs)  -- main case of unescaped value+  one [] = return Nothing+  one ('\\':[]) = Left "cannot understand a string that ends with a backslash"+  one ('\\':'0':ys) = return $ Just ([0],ys)+  one ('\\':ys) | 1 <= len =+      case mayRead readOct oct of+        Just w -> do w' <- checkByte w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode octal sequence "++ys+    where oct = takeWhile isOctDigit (take 3 ys)+          len = length oct+          rest = drop len ys+  one ('\\':x:ys) | 'x' == toLower x && 1 <= len =+      case mayRead readHex hex of+        Just w -> do w' <- checkByte w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode hex sequence "++ys+    where hex = takeWhile isHexDigit (take 2 ys)+          len = length hex+          rest = drop len ys          +  one ('\\':'u':ys) | ok =+      case mayRead readHex hex of+        Just w -> do w' <- checkUnicode w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode 4 char unicode sequence "++ys+    where ok = all isHexDigit hex && 4 == length hex+          (hex,rest) = splitAt 4 ys+  one ('\\':'U':ys) | ok =+      case mayRead readHex hex of+        Just w -> do w' <- checkUnicode w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode 8 char unicode sequence "++ys+    where ok = all isHexDigit hex && 8 == length hex+          (hex,rest) = splitAt 8 ys+  one ('\\':(x:xs)) = do x' <- decode x+                         return $ Just ([x'],xs)+  decode :: Char -> Either String Word8+  decode 'a' = return 7+  decode 'b' = return 8+  decode 't' = return 9+  decode 'n' = return 10+  decode 'v' = return 11+  decode 'f' = return 12+  decode 'r' = return 13+  decode '\"' = return 34+  decode '\'' = return 39+  decode '?' = return 63    -- C99 rule : "\?" is '?'+  decode '\\' = return 92+  decode x | toLower x == 'x' = Left "cannot understand your 'xX' hexadecimal escaped value"+  decode x | toLower x == 'u' = Left "cannot understand your 'uU' unicode UTF-8 hexadecimal escaped value"+  decode _ = Left "cannot understand your backslash-escaped value"+  checkChar8 :: Char -> Either String [Word8]+  checkChar8 c | (0 <= i) && (i <= 255) = Right [toEnum i]+               | otherwise = Left $ "found Char out of range 0..255, value="++show (ord c)+    where i = fromEnum c+  checkByte :: Integer -> Either String [Word8]+  checkByte i | (0 <= i) && (i <= 255) = Right [fromInteger i]+              | otherwise = Left $ "found Oct/Hex Int out of range 0..255, value="++show i+  checkUnicode :: Integer -> Either String [Word8]+  checkUnicode i | (0 <= i) && (i <= 127) = Right [fromInteger i]+                 | i <= maxChar = Right $ encode [ toEnum . fromInteger $ i ]+                 | otherwise = Left $ "found Unicode Char out of range 0..0x10FFFF, value="++show i+    where maxChar = toInteger (fromEnum (maxBound ::Char)) -- 0x10FFFF+++alex_action_4 =  parseDec +alex_action_5 =  parseOct +alex_action_6 =  parseHex +alex_action_7 =  parseDouble +alex_action_8 =  dieAt "decimal followed by invalid character" +alex_action_9 =  dieAt "octal followed by invalid character" +alex_action_10 =  dieAt "hex followed by invalid character" +alex_action_11 =  dieAt "floating followed by invalid character" +alex_action_12 =  parseStr +alex_action_13 =  parseName +alex_action_14 =  parseChar +alex_action_15 =  wtfAt +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 35 "templates/GenericTemplate.hs" #-}++{-# LINE 45 "templates/GenericTemplate.hs" #-}++{-# LINE 66 "templates/GenericTemplate.hs" #-}+alexIndexInt16OffAddr arr off = arr ! off+++{-# LINE 87 "templates/GenericTemplate.hs" #-}+alexIndexInt32OffAddr arr off = arr ! off+++{-# LINE 98 "templates/GenericTemplate.hs" #-}+quickIndex arr i = arr ! i+++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+  = AlexEOF+  | AlexError  !AlexInput+  | AlexSkip   !AlexInput !Int+  | AlexToken  !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (sc)+  = alexScanUser undefined input (sc)++alexScanUser user input (sc)+  = case alex_scan_tkn user input (0) input sc AlexNone of+	(AlexNone, input') ->+		case alexGetChar input of+			Nothing -> ++++				   AlexEOF+			Just _ ->++++				   AlexError input'++	(AlexLastSkip input len, _) ->++++		AlexSkip input len++	(AlexLastAcc k input len, _) ->++++		AlexToken input len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+  input `seq` -- strict in the input+  let +	new_acc = check_accs (alex_accept `quickIndex` (s))+  in+  new_acc `seq`+  case alexGetChar input of+     Nothing -> (new_acc, input)+     Just (c, new_input) -> ++++	let+		base   = alexIndexInt32OffAddr alex_base s+		(ord_c) = ord c+		offset = (base + ord_c)+		check  = alexIndexInt16OffAddr alex_check offset+		+		new_s = if (offset >= (0)) && (check == ord_c)+			  then alexIndexInt16OffAddr alex_table offset+			  else alexIndexInt16OffAddr alex_deflt s+	in+	case new_s of +	    (-1) -> (new_acc, input)+		-- on an error, we want to keep the input *before* the+		-- character that failed, not after.+    	    _ -> alex_scan_tkn user orig_input (len + (1)) +			new_input new_s new_acc++  where+	check_accs [] = last_acc+	check_accs (AlexAcc a : _) = AlexLastAcc a input (len)+	check_accs (AlexAccSkip : _)  = AlexLastSkip  input (len)+	check_accs (AlexAccPred a pred : rest)+	   | pred user orig_input (len) input+	   = AlexLastAcc a input (len)+	check_accs (AlexAccSkipPred pred : rest)+	   | pred user orig_input (len) input+	   = AlexLastSkip input (len)+	check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+  = AlexNone+  | AlexLastAcc a !AlexInput !Int+  | AlexLastSkip  !AlexInput !Int++data AlexAcc a user+  = AlexAcc a+  | AlexAccSkip+  | AlexAccPred a (AlexAccPred user)+  | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+  = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (sc) user _ _ input = +     case alex_scan_tkn user input (0) input sc AlexNone of+	  (AlexNone, _) -> False+	  _ -> True+	-- TODO: there's no need to find the longest+	-- match when checking the right context, just+	-- the first match will do.++-- used by wrappers+iUnbox (i) = i
+ Text/ProtocolBuffers/Lexer.x view
@@ -0,0 +1,178 @@+{+module Text.ProtocolBuffers.Lexer (Lexed(..), alexScanTokens,getLinePos)  where++import Control.Monad.Error()+import Codec.Binary.UTF8.String(encode)+import qualified Data.ByteString.Lazy as L+import Data.Char(ord,chr,isHexDigit,isOctDigit,toLower)+import Data.List(sort,unfoldr)+import Data.Word(Word8)+import Numeric(readHex,readOct,readDec,showOct,readSigned,readFloat)++}++%wrapper "posn-bytestring"++$d = [0-9]+@decInt = [\-]?[1-9]$d*+@hexInt = [\-]?0[xX]([A-Fa-f0-9])++@octInt = [\-]?0[0-7]*+@doubleLit = [\-]?$d+(\.$d+)?([Ee][\+\-]?$d+)?++@ident1 = [A-Za-z_][A-Za-z0-9_]*+@ident = [\.]?@ident1([\.]@ident1)*+@notChar = [^A-Za-z0-9_]++@hexEscape = \\[Xx][A-Fa-f0-9]{1,2}+@octEscape = \\0?[0-7]{1,3}+@charEscape = \\[abfnrtv\\\?'\"]+@inStr = @hexEscape | @octEscape | @charEscape | [^'\"\0\n]+@strLit = ['] (@inStr | [\"])* ['] | [\"] (@inStr | ['])* [\"]++$special    = [=\(\)\,\;\[\]\{\}]++:-++  $white+ ;+  "//".*  ;+  "#".*   ;+  "/*".*"*/" ;+  @decInt / @notChar    { parseDec }+  @octInt / @notChar    { parseOct }+  @hexInt / @notChar    { parseHex }+  @doubleLit / @notChar { parseDouble }+  @decInt               { dieAt "decimal followed by invalid character" }+  @octInt               { dieAt "octal followed by invalid character" }+  @hexInt               { dieAt "hex followed by invalid character" }+  @doubleLit            { dieAt "floating followed by invalid character" }+  @strLit               { parseStr }+  @ident                { parseName }+  $special              { parseChar }+  .                     { wtfAt }++{+line :: AlexPosn -> Int+line (AlexPn _byte line' _col) = line'+{-# INLINE line #-}++data Lexed = L_Integer !Int !Integer+           | L_Double !Int !Double+           | L_Name !Int !L.ByteString+           | L_String !Int !L.ByteString+           | L !Int !Char+           | L_Error !Int !String+  deriving (Show,Eq)++getLinePos :: Lexed -> Int+getLinePos x = case x of+                 L_Integer i _ -> i+                 L_Double  i _ -> i+                 L_Name    i _ -> i+                 L_String  i _ -> i+                 L         i _ -> i+                 L_Error   i _ -> i++-- 'errAt' is the only access to L_Error, so I can see where it is created with pos+errAt pos msg =  L_Error (line pos) $ "Lexical error (in Text.ProtocolBuffers.Lexer): "++ msg ++ ", at "++see pos where+  see (AlexPn char line col) = "character "++show char++" line "++show line++" column "++show col++"."+dieAt msg pos _s = errAt pos msg+wtfAt pos s = errAt pos $ "unknown character "++show c++" (decimal "++show (ord c)++")"+  where (c:_) = ByteString.unpack s++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++-- Given the regexps above, the "parse* failed" messages should be impossible.+parseDec pos s = maybe (errAt pos "parseDec failed") (L_Integer (line pos)) $ mayRead (readSigned readDec) (ByteString.unpack s)+parseOct pos s = maybe (errAt pos "parseOct failed") (L_Integer (line pos)) $ mayRead (readSigned readOct) (ByteString.unpack s)+parseHex pos s = maybe (errAt pos "parseHex failed") (L_Integer (line pos)) $ mayRead (readSigned (readHex . drop 2)) (ByteString.unpack s)+parseDouble pos s = maybe (errAt pos "parseDouble failed") (L_Double (line pos)) $ mayRead (readSigned readFloat) (ByteString.unpack s)+parseStr pos s = either (errAt pos) (L_String (line pos) . L.pack) $ sDecode . ByteString.unpack $ (ByteString.init (ByteString.tail s))+parseName pos s = L_Name (line pos) s+parseChar pos s = L (line pos) (ByteString.head s)++-- Generalization of concat . unfoldr to monadic-Either form:+op :: ( [Char] -> Either String (Maybe ([Word8],[Char]))) -> [Char] -> Either String [Word8]+op one = go id where+  go f cs = case one cs of+              Left msg -> Left msg+              Right Nothing -> Right (f [])+              Right (Just (ws,cs)) -> go (f . (ws++)) cs++-- Put this mess in the lexer, so the rest of the code can assume+-- everything is saner.  The input is checked to really be "Char8"+-- values in the range [0..255] and to be c-escaped (in order to+-- render binary information printable).  This decodes the c-escaping+-- and returns the binary data as Word8.+-- +-- A decoding error causes (Left msg) to be returned.+sDecode :: [Char] -> Either String [Word8]+sDecode = op one where+  one :: [Char] -> Either String (Maybe ([Word8],[Char]))+  one (x:xs) | x /= '\\' = do x' <- checkChar8 x+                              return $ Just (x',xs)  -- main case of unescaped value+  one [] = return Nothing+  one ('\\':[]) = Left "cannot understand a string that ends with a backslash"+  one ('\\':'0':ys) = return $ Just ([0],ys)+  one ('\\':ys) | 1 <= len =+      case mayRead readOct oct of+        Just w -> do w' <- checkByte w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode octal sequence "++ys+    where oct = takeWhile isOctDigit (take 3 ys)+          len = length oct+          rest = drop len ys+  one ('\\':x:ys) | 'x' == toLower x && 1 <= len =+      case mayRead readHex hex of+        Just w -> do w' <- checkByte w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode hex sequence "++ys+    where hex = takeWhile isHexDigit (take 2 ys)+          len = length hex+          rest = drop len ys          +  one ('\\':'u':ys) | ok =+      case mayRead readHex hex of+        Just w -> do w' <- checkUnicode w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode 4 char unicode sequence "++ys+    where ok = all isHexDigit hex && 4 == length hex+          (hex,rest) = splitAt 4 ys+  one ('\\':'U':ys) | ok =+      case mayRead readHex hex of+        Just w -> do w' <- checkUnicode w+                     return $ Just (w',rest)+        Nothing -> Left $ "failed to decode 8 char unicode sequence "++ys+    where ok = all isHexDigit hex && 8 == length hex+          (hex,rest) = splitAt 8 ys+  one ('\\':(x:xs)) = do x' <- decode x+                         return $ Just ([x'],xs)+  decode :: Char -> Either String Word8+  decode 'a' = return 7+  decode 'b' = return 8+  decode 't' = return 9+  decode 'n' = return 10+  decode 'v' = return 11+  decode 'f' = return 12+  decode 'r' = return 13+  decode '\"' = return 34+  decode '\'' = return 39+  decode '?' = return 63    -- C99 rule : "\?" is '?'+  decode '\\' = return 92+  decode x | toLower x == 'x' = Left "cannot understand your 'xX' hexadecimal escaped value"+  decode x | toLower x == 'u' = Left "cannot understand your 'uU' unicode UTF-8 hexadecimal escaped value"+  decode _ = Left "cannot understand your backslash-escaped value"+  checkChar8 :: Char -> Either String [Word8]+  checkChar8 c | (0 <= i) && (i <= 255) = Right [toEnum i]+               | otherwise = Left $ "found Char out of range 0..255, value="++show (ord c)+    where i = fromEnum c+  checkByte :: Integer -> Either String [Word8]+  checkByte i | (0 <= i) && (i <= 255) = Right [fromInteger i]+              | otherwise = Left $ "found Oct/Hex Int out of range 0..255, value="++show i+  checkUnicode :: Integer -> Either String [Word8]+  checkUnicode i | (0 <= i) && (i <= 127) = Right [fromInteger i]+                 | i <= maxChar = Right $ encode [ toEnum . fromInteger $ i ]+                 | otherwise = Left $ "found Unicode Char out of range 0..0x10FFFF, value="++show i+    where maxChar = toInteger (fromEnum (maxBound ::Char)) -- 0x10FFFF++}
Text/ProtocolBuffers/Mergeable.hs view
@@ -1,44 +1,37 @@--- This is isomorphic to Monoid(mappend), but allows the derired instances without overlapping.--- It also gives a default implementation to mergeAppend to take the second entry. module Text.ProtocolBuffers.Mergeable(Mergeable(..),mayMerge) where+-- This types are isomorphic to Monoid(mappend).  But the sematics are+-- different, since mergeEmpty is likely only a left idenitity and not+-- a right identity. The Mergeable class also has a default+-- implementation to mergeAppend that take the second parameter. -import Data.ByteString(ByteString)-import Data.Sequence(Seq)+import Text.ProtocolBuffers.Basic+import qualified Data.Foldable as F(Foldable(foldr)) import Data.Monoid(mempty,mappend)-import Data.Int(Int32,Int64)-import Data.Word(Word32,Word64)  class Mergeable a where   mergeEmpty :: a-  mergeEmpty = error "You did not define Mergeable.mergeEmpty!"+-- mergeEmpty = error "You did not define Mergeable.mergeEmpty!"+   mergeAppend :: a -> a -> a   mergeAppend a b = b-  mergeConcat :: [a] -> a-  mergeConcat = foldr mergeAppend mergeEmpty +  mergeConcat :: F.Foldable t => t a -> a+  mergeConcat = F.foldr mergeAppend mergeEmpty+ -- Base types are not very mergeable, but their Maybe type are:-instance Mergeable Bool where-instance Mergeable Int32 where-instance Mergeable Int64 where-instance Mergeable Word32 where-instance Mergeable Word64 where-instance Mergeable ByteString where-instance Mergeable (Maybe Bool) where mergeEmpty = Nothing; mergeAppend = mayMerge-instance Mergeable (Maybe Int32) where mergeEmpty = Nothing; mergeAppend = mayMerge-instance Mergeable (Maybe Int64) where mergeEmpty = Nothing; mergeAppend = mayMerge-instance Mergeable (Maybe Word32) where mergeEmpty = Nothing; mergeAppend = mayMerge-instance Mergeable (Maybe Word64) where mergeEmpty = Nothing; mergeAppend = mayMerge-instance Mergeable (Maybe ByteString) where mergeEmpty = Nothing; mergeAppend = mayMerge+instance Mergeable a => Mergeable (Maybe a) where mergeEmpty = Nothing; mergeAppend = mayMerge instance Mergeable (Seq a) where mergeEmpty = mempty; mergeAppend = mappend+instance Mergeable Bool where mergeEmpty = False+instance Mergeable ByteString where mergeEmpty = mempty+instance Mergeable Double where mergeEmpty = 0.0+instance Mergeable Float where mergeEmpty = 0.0+instance Mergeable Int32 where mergeEmpty = 0+instance Mergeable Int64 where mergeEmpty = 0+instance Mergeable Word32 where mergeEmpty = 0+instance Mergeable Word64 where mergeEmpty = 0  {-# INLINE mayMerge #-} mayMerge :: (Mergeable b) => Maybe b -> Maybe b -> Maybe b-mayMerge Nothing y = y-mayMerge x Nothing = x+mayMerge Nothing  y        = y+mayMerge x        Nothing  = x mayMerge (Just x) (Just y) = Just (mergeAppend x y)--{-# INLINE mayLast #-}-mayLast :: Maybe b -> Maybe b -> Maybe b-mayLast Nothing y = y-mayLast x Nothing = x-mayLast _ y = y
+ Text/ProtocolBuffers/MyGet.hs view
@@ -0,0 +1,876 @@+{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,MultiParamTypeClasses,TypeSynonymInstances,BangPatterns,FunctionalDependencies,RankNTypes #-}+--+-- By Chris Kuklewicz, drawing heavily from binary and binary-strict.+-- but all the bugs are my own.+--+-- This file is under the usual BSD3 licence, copyright 2008.+--+-- There is a sibling to this module (once called "MyGetW") that does+-- have a MonadCont instances, and does not hide the "b" type variable+-- with a forall.  In fact this file is a search-and-delete version of+-- MyGetW.hs+--+-- This started out as an improvement to Data.Binary.Strict.IncrementalGet with+-- slightly better internals.  The simplified "get,runGet,Result" trio with the+-- 'Data.Binary.Strict.Class.BinaryParser' instance are an _untested_+-- upgrade from IncrementalGet.  Especially untested are the+-- strictness properties.+--+-- 'Get' implements usefully Applicative and Monad, MonadError,+-- Alternative and MonadPlus.+-- +-- The 'CompGet' monad transformer has those and also useful MonadRead,+-- MonadWriter, and MonadState implementations.  Output to the writer+-- and changes to the State are thrown away when fail/throwError/mzero+-- is called.+-- +-- The semantics of throwError interating with MonadState and+-- MonadWriter and BinaryParser: an error reverts all changes to the+-- state and drops all items tell'd.  The position in the input stream+-- is rewound, but all items gotten from 'suspend' are kept.  Any+-- changes from 'putAvailable' are kept.  Thus throwError aborts any+-- 'listen' or 'pass' contexts.+--+-- Top level errors are reported along with number of bytes successfully consumed.+--+-- Each time the parser reaches the end of the input it will return a+-- Partial or CPartial Left-wrapped continuation which requests a+-- (Maybe Lazy.ByteString).  Passing (Just bs) will append bs to the+-- input so far.  If you pass Nothing to the continuation, then you+-- are declaring that there will never be more input and the parser+-- should never again return a partial contination; it should return+-- failure or finished.+--+-- The newest feaature is the ability for the computation to return a+-- stream of results.  The use of 'yieldItem' cannot be rolled back,+-- no subsequenct throwError,mzero,fail,lookAhead, or use of callCC+-- will lose any yielded value.  To report yielded value at an+-- intermediate point, without asking for more input, use+-- 'flushItems'.  To get a count of items yielded and not flushed, use+-- 'pendingItems', which returns 0 immediately after 'flushItems'.+--+-- 'suspendUntilComplete' repeatedly uses a partial continuation to+-- ask for more input until Nothing is passed and then it proceeds+-- with parsing.+--+-- The 'getAvailable' command returns the lazy byte string the parser+-- has remaining before calling 'suspend'.  The 'putAvailable'+-- replaces this input and is a bit fancy: it also replaces the input+-- at the current offset for all the potential catchError/mplus+-- handlers.  This change is _not_ reverted by fail/throwError/mzero.+--+-- The three 'lookAhead' and 'lookAheadM' and 'lookAheadE' functions are+-- the same as the ones in binary's Data.Binary.Get.+--+-- 'getCC' and 'getCC1' are handy wrapper of 'callCC' that I have included here.+--+module Text.ProtocolBuffers.MyGet+    (Get,runGet,Result(..)+    ,CompGet,runCompGet,CompResult(..)+     -- main primitives to parse items+    ,ensureBytes,getStorable,getLazyByteString,getByteString,suspendUntilComplete+     -- observe or replace the remaining BinaryParser input+    ,getAvailable,putAvailable+     -- return a Sequence of items.+    ,yieldItem,flushItems,pendingItems+     -- lookAhead capabilities+    ,lookAhead,lookAheadM,lookAheadE+     -- below is for implementation of BinaryParser (for Int64 and Lazy bytestrings)+    ,bytesRead,isEmpty,remaining+    ,skip,spanOf+    ,getWord8,getWordhost+    ,getWord16be,getWord32be,getWord64be+    ,getWord16le,getWord32le,getWord64le+    ,getWord16host,getWord32host,getWord64host+    ) where++-- import Debug.Trace(trace)++-- The InternalGet monad is an instance of binary-strict's BinaryParser:+import qualified Data.Binary.Strict.Class as P(BinaryParser(..))+-- The InternalGet monad is an instance of all of these...+import Control.Applicative(Alternative(..),Applicative(..))+import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg,noMsg))+import Control.Monad.Reader.Class(MonadReader(ask,local))+import Control.Monad.Writer.Class(MonadWriter(tell,listen,pass))+import Control.Monad.State.Class(MonadState(get,put))+import Control.Monad.Trans(MonadTrans(lift),MonadIO(liftIO))+import Control.Monad(MonadPlus(mzero,mplus))++import Data.Char++-- implementation imports+import Control.Monad(liftM,ap)                       -- instead of Functor.fmap; ap for Applicative+import Control.Monad(replicateM)                      -- XXX testing+import Control.Monad((>=>)) -- XX testing+import Control.Monad.Identity(Identity,runIdentity)  -- Get is a transformed Identity monad+import Data.Bits(Bits((.|.)))+import qualified Data.ByteString as S(concat,length,null,splitAt)+import qualified Data.ByteString as S(pack,unpack) -- XXX testing+import qualified Data.ByteString.Internal as S(ByteString,toForeignPtr,inlinePerformIO)+import qualified Data.ByteString.Unsafe as S(unsafeIndex)+import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,empty)+import qualified Data.ByteString.Lazy as L(pack,unpack) -- XXX testing+import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk)+import qualified Data.Foldable as F(foldr1)          -- used with Seq+import Data.Function(fix)                            -- used in clever definition of getCC+import Data.Int(Int64)                               -- index type for L.ByteString+import Data.Monoid(Monoid(mempty,mappend))           -- Writer has a Monoid contraint+import Data.Sequence(Seq,length,null,(|>))           -- used for future queue in handler state+import Data.Word(Word,Word8,Word16,Word32,Word64)+import Foreign.ForeignPtr(withForeignPtr)+import Foreign.Ptr(castPtr,plusPtr)+import Foreign.Storable(Storable(peek,sizeOf))+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base(Int(..),uncheckedShiftL#)+import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#)+#endif++default()++-- Simple external return type+data Result y a = Failed !(Seq y) {-# UNPACK #-} !Int64 String+                | Finished !(Seq y) {-# UNPACK #-} !L.ByteString {-# UNPACK #-} !Int64 a+                | Partial !(Seq y) !(Either ( Result y a  )  -- use laziness+                                            ( Maybe L.ByteString -> Result y a ))++-- Complex external return type+data CompResult y w user m a =+    CFailed !(Seq y) {-# UNPACK #-} !Int64 String+  | CFinished  !(Seq y) {-# UNPACK #-} !L.ByteString {-# UNPACK #-} !Int64 w user a+  | CPartial !(Seq y) !(Either ( m (CompResult y w user m a) ) -- use laziness+                                   ( Maybe L.ByteString -> m (CompResult y w user m a) ))++-- Internal type, converted to an external type before returning to caller.+data IResult y e w user m a =+    IFailed !(Seq y) {-# UNPACK #-} !Int64 e+  | IFinished !(Seq y) w {-# UNPACK #-} !(S user) a+  | IPartial !(Seq y) !(Either ( m (IResult y e w user m a) )+                               ( Maybe L.ByteString -> m (IResult y e w user m a) ))++-- Internal state type, not exposed to the user.+data S user = S { top :: {-# UNPACK #-} !S.ByteString+                , current :: {-# UNPACK #-} !L.ByteString+                , consumed :: {-# UNPACK #-} !Int64+                , user_field :: user+                }+  deriving Show++-- easier names+type SuccessContinuation b y e r w user m a =+  (a -> r -> w -> (S user) -> TopFrame b y e w user m -> m (IResult y e w user m b))++type ErrorHandler b y e w user m =+  ( (S user) -> TopFrame b y e w user m -> e -> m (IResult y e w user m b))++-- Private Internal error handling stack type+-- This must NOT be exposed by this module+data FrameStack b y e w user m =+    ErrorFrame { top_error_handler :: ErrorHandler b y e w user m -- top level handler+               , input_continues :: {-# UNPACK #-} !Bool -- True at start, False if Nothing passed to suspend continuation+               }+  | HandlerFrame { error_handler :: !(Maybe (ErrorHandler b y e w user m))  -- encapsulated handler+                 , stored_state :: {-# UNPACK #-} !(S user)  -- stored state to pass to handler+                 , future_input :: {-# UNPACK #-} !(Seq L.ByteString)  -- additiona input to hass to handler+                 , older_frame :: !(FrameStack b y e w user m)  -- older handlers+                 }++-- TopFrame is used as storage for a unique counter (Word64) that is+-- used to label the HanderFrames in increasing order as they are+-- created.  This is only needed so that callCC can distinguish the age+-- of items in the FrameStack as being present at the original use of +-- callCC or being newer.+--+-- TopFrame's unique value is used and incremented when a new+-- HandlerFrame is allocated by catchError.  It will start at 1.+--+-- The (Seq y) of of yielded values in the TopFrame are the yielded+-- results which are waiting to be put in the next IReturn value.+data TopFrame b y e w user m  = TopFrame (Seq y) (FrameStack b y e w user m)+  deriving Show++-- Internal monad type+newtype InternalGet y e r w user m a = InternalGet {+      unInternalGet :: forall b.+                 SuccessContinuation b y e r w user m a+              -> r                          -- reader+              -> w                          -- log so far+              -> (S user)                   -- state+              -> TopFrame b y e w user m    -- error handler stack+              -> m (IResult y e w user m b) -- operation+      }++-- Complex external monad type, but errors are String+type CompGet y r w user m = InternalGet y String r w user m++-- Simple external monad type+type Get y = CompGet y () () () Identity++-- These implement the checkponting needed to store and revive the+-- state for lookAhead.  They are fragile because the setCheckpoint+-- must preceed either useCheckpoint or clearCheckpoint but not both.+-- The FutureFrame must be the most recent handler, so the commands+-- must be in the same scope depth.  Because of these constraints, the reader+-- value 'r' does not need to be stored and can be taken from the InternalGet+-- parameter.+--+-- IMPORTANT: Any FutureFrame at the top level(s) is discarded by throwError.+setCheckpoint,useCheckpoint,clearCheckpoint :: InternalGet y e r w user m ()+setCheckpoint = InternalGet $ \ sc r w s (TopFrame ys pc) ->+  sc () r w s (TopFrame ys (HandlerFrame Nothing s mempty pc))+useCheckpoint = InternalGet $ \ sc r w sIn (TopFrame ys (HandlerFrame catcher sOld future pc)) ->+  case catcher of+    Just {} -> error "Impossible: Bad use of useCheckpoint, error_handler was Just instead of Nothing"+    Nothing -> let sOut = (collect sOld future) { user_field = user_field sIn }+               in sc () r w sOut (TopFrame ys pc)+clearCheckpoint = InternalGet $ \ sc r w s (TopFrame ys (HandlerFrame catcher _s _future pc)) ->+  case catcher of+    Just {} -> error "Impossible: Bad use of clearCheckpoint, error_handler was Just instead of Nothing"+    Nothing -> sc () r w s (TopFrame ys pc)++-- | 'lookAhead' runs the @todo@ action and then rewinds only the+-- BinaryParser state.  Any new input from 'suspend' or changes from+-- 'putAvailable' are kept.  Changes to the user state (MonadState)+-- are kept.  The MonadWriter output is retained.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAhead :: (Monad m, Error e)+          => InternalGet y e r w user m a+          -> InternalGet y e r w user m a+lookAhead todo = do+  setCheckpoint+  a <- todo+  useCheckpoint+  return a++-- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the +-- BinaryParser state is rewound (as in 'lookAhead').  If the action return 'Just' then+-- the BinaryParser is not rewound, and lookAheadM acts as an identity.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAheadM :: (Monad m, Error e)+           => InternalGet y e r w user m (Maybe a)+           -> InternalGet y e r w user m (Maybe a)+lookAheadM todo = do+  setCheckpoint+  a <- todo+  maybe useCheckpoint (\_ -> clearCheckpoint) a+  return a++-- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the +-- BinaryParser state is rewound (as in 'lookAhead').  If the action return 'Right' then+-- the BinaryParser is not rewound, and lookAheadE acts as an identity.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAheadE :: (Monad m, Error e)+           => InternalGet y e r w user m (Either a b)+           -> InternalGet y e r w user m (Either a b)+lookAheadE todo = do+  setCheckpoint+  a <- todo+  either (\_ -> useCheckpoint) (\_ -> clearCheckpoint) a+  return a++-- 'collect' is used by 'putCheckpoint' and 'throwError'+collect :: (S user) -> Seq L.ByteString -> (S user)+collect sIn future | Data.Sequence.null future = sIn+                   | otherwise = sIn { current = mappend (current sIn) (F.foldr1 mappend future) }++instance (Show a,Show y) => Show (Result y a) where+  showsPrec _ (Failed ys n msg) = scon "Failed" $ sparen ys . sshows n . sshows msg+  showsPrec _ (Finished ys bs n a) = scon "Finished" $ sparen ys . sparen bs . sshows n . sparen a+  showsPrec _ (Partial ys c) = scon "Partial" $ sparen ys . showsEither c++instance (Show w, Show user, Show a,Show y) => Show (CompResult y w user m a) where+  showsPrec _ (CFailed ys n msg) = scon "CFailed" $ sparen ys . sshows n . sshows msg+  showsPrec _ (CFinished ys bs n w user a) = scon "CFinished" $ sparen ys . sparen bs . sshows n . sparen w . sparen user . sparen a+  showsPrec _ (CPartial ys c) = scon "CPartial" $ sparen ys . showsEither c++instance (Show user, Show a, Show w,Show y,Show e) => Show (IResult y e w user m a) where+  showsPrec _ (IFailed ys n msg) = scon "IFailed" $ sparen ys . sshows n . sshows msg+  showsPrec _ (IFinished ys w s a) = scon "CFinished" $ sparen ys . sparen w . sparen s . sparen a+  showsPrec _ (IPartial ys c) = scon "CPartial" $ sparen ys . showsEither c++instance (Show s,Show y) => Show (FrameStack b y e w s m) where+  showsPrec _ (ErrorFrame _ec p) = scon "ErrorFrame <>" $ sshows p+  showsPrec _ (HandlerFrame _catcher s future pc) = scon "(HandlerFrame " $ (" <>"++) . sparen s . sparen future . ('\n':) . indent . shows pc++scon :: String -> ShowS -> ShowS+scon c s = ("("++) . (c++) . (' ':) . s . (')':)+sparen :: (Show x) => x -> ShowS+sparen s = (" ("++) . shows s . (')':)+sshows :: (Show x) => x -> ShowS+sshows s = (' ':) . shows s +indent :: String -> String+indent = unlines . map ("  "++) . lines+showsEither :: Either a b -> ShowS+showsEither (Left {}) = shows " (Left <>)"+showsEither (Right {}) = shows " (Right <>)"++chunk :: S user -> L.ByteString+chunk s = L.chunk (top s) (current s)++-- | 'runCompGet' is the complex executor+runCompGet :: (Monad m,Monoid w)+            => CompGet y r w user m a+            -> r -> user -> L.ByteString+            -> m (CompResult y w user m a)+runCompGet g rIn userIn bsIn = liftM convert (unInternalGet g scIn rIn mempty sIn (TopFrame mempty (ErrorFrame ecIn True)))+  where sIn = case bsIn of L.Empty -> S mempty mempty 0 userIn+                           L.Chunk ss bs -> S ss bs 0 userIn+        scIn a _r w sOut (TopFrame ys _pc) = return (IFinished ys w sOut a)+        ecIn sOut (TopFrame ys _pc) msg = return (IFailed ys (consumed sOut) msg)++        convert :: (Monad m) => IResult y String w user m a -> CompResult y w user m a+        convert (IFailed ys n msg) = CFailed ys n msg+        convert (IFinished ys w (S ss bs n user) a) = CFinished ys (L.chunk ss bs) n w user a+        convert (IPartial ys f) = CPartial ys (case f of+                                                 Left f' -> Left $ liftM convert f'+                                                 Right f' -> Right $ \bs -> liftM convert (f' bs) )++-- | 'runGet' is the simple executor+runGet :: Get y a -> L.ByteString -> Result y a+runGet g bsIn = convert (runIdentity (unInternalGet g scIn () mempty sIn (TopFrame mempty (ErrorFrame ecIn True))))+  where sIn = case bsIn of L.Empty -> S mempty mempty 0 ()+                           L.Chunk ss bs -> S ss bs 0 ()+        scIn a _r w sOut (TopFrame ys _pc) = return (IFinished ys w sOut a)+        ecIn sOut (TopFrame ys _pc) msg = return (IFailed ys (consumed sOut) msg)++        convert :: IResult y String () () Identity a -> Result y a+        convert (IFailed ys n msg) = Failed ys n msg+        convert (IFinished ys _w (S ss bs n _user) a) = Finished ys (L.chunk ss bs) n a+        convert (IPartial ys f) = Partial ys (case f of+                                                Left f' -> Left $ convert (runIdentity f')+                                                Right f' -> Right $ \bs -> convert (runIdentity (f' bs)))++-- | Get the input currently available to the parser.  If this is+-- preceded by 'suspendUntilComplete' then this will definitely by the+-- complete length.+getAvailable :: InternalGet y e r w user m L.ByteString+getAvailable = InternalGet $ \ sc r w s pc -> sc (chunk s) r w s pc++-- | 'putAvailable' replaces the bytestream past the current # of read+-- bytes.  This will also affect pending MonadError handler and+-- MonadPlus branches.  I think all pending branches have to have+-- fewer bytesRead than the current one.  If this is wrong then an+-- error will be thrown.+--+-- Currently this does not change the flag which indicates whether+-- Nothing has ever been passed to a continuation to indicate the hard+-- end of input.  This poperty is subject to change.+--+-- WARNING : 'putAvailable' is still untested.+putAvailable :: L.ByteString -> InternalGet y e r w user m ()+putAvailable bsNew = InternalGet $ \ sc r w (S _ss _bs n user) (TopFrame ys pc) ->+  let s' = case bsNew of+             L.Empty -> S mempty mempty n user+             L.Chunk ss' bs' -> S ss' bs' n user+      rebuild (HandlerFrame catcher sOld@(S _ss1 _bs1 n1 user1) future pc') =+               HandlerFrame catcher sNew mempty (rebuild pc')+        where balance = n - n1+              whole | balance < 0 = error "Impossible? Cannot rebuild HandlerFrame in MyGetW.putAvailable: balance is negative!"+                    | otherwise = L.take balance . chunk $ collect sOld future+              sNew | balance /= L.length whole = error "Impossible? MyGetW.putAvailable.rebuild.sNew HandlerFrame assertion failed."+                   | otherwise = case mappend whole bsNew of+                                   L.Empty -> S mempty mempty n1 user1+                                   L.Chunk ss2 bs2 -> S ss2 bs2 n1 user1+      rebuild x@(ErrorFrame {}) = x+  in sc () r w s' (TopFrame ys (rebuild pc))++-- Internal access to full internal state, as helepr functions+getFull :: InternalGet y e r w user m (S user)+getFull = InternalGet $ \ sc r w s pc -> sc s r w s pc+putFull :: (S user) -> InternalGet y e r w user m ()+putFull s = InternalGet $ \ sc r w _s pc -> sc () r w s pc++-- | Keep calling 'suspend' until Nothing is passed to the 'Partial'+-- continuation.  This ensures all the data has been loaded into the+-- state of the parser.+suspendUntilComplete :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m ()+suspendUntilComplete = do+  continue <- suspend+  if continue then suspendUntilComplete+    else return ()++-- | Call suspend and throw and error with the provided @msg@ if+-- Nothing has been passed to the 'Partial' continuation.  Otherwise+-- return ().+suspendMsg :: ({-Show user,-} Error e, Monad m) => e -> InternalGet y e r w user m ()+suspendMsg msg = do continue <- suspend+                    if continue then return ()+                      else throwError msg+{-# INLINE suspendMsg #-}++-- | check that there are at least @n@ bytes available in the input.+-- This will suspend if there is to little data.+ensureBytes :: ({-Show user,-} Error e, Monad m) => Int64 -> InternalGet y e r w user m ()+ensureBytes n = do+  (S ss bs _offset _user) <- getFull+  if n < fromIntegral (S.length ss)+    then return ()+    else do if n == L.length (L.take n (L.chunk ss bs))+              then return ()+              else suspendMsg (strMsg "ensureBytes failed") >> ensureBytes n+{-# INLINE ensureBytes #-}++-- | Pull @n@ bytes from the unput, as a lazy ByteString.  This will+-- suspend if there is too little data.  +getLazyByteString :: ({-Show user,-} Error e, Monad m) => Int64 -> InternalGet y e r w user m L.ByteString+getLazyByteString n = do+  (S ss bs offset user) <- getFull+  case splitAtOrDie n (L.chunk ss bs) of+    Just (consume,rest) -> do case rest of+                                L.Empty -> putFull (S mempty mempty (offset + n) user)+                                L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n) user)+                              return consume+    Nothing -> suspendMsg (strMsg "getLazyByteString failed") >> getLazyByteString n+{-# INLINE getLazyByteString #-} -- important++-- | 'suspend' is supposed to allow the execution of the monad to be+-- halted, awaiting more input.  The computation is supposed to+-- continue normally if this returns True, and is supposed to halt+-- without calling suspend again if this returns False.  All future+-- calls to suspend will return False automatically and no nothing+-- else.+--+-- These semantics are too specialized to let this escape this module.+class MonadSuspend y m | m -> y where+  suspend :: m Bool+  yieldItem :: y -> m ()+  flushItems :: m ()+  pendingItems :: m Int++-- The instance here is fairly specific to the stack manipluation done+-- by 'addFuture' to ('S' user) and to the packaging of the resumption+-- function in 'IResult'('IPartial').+instance ({-Show user,-} Error e, Monad m) => MonadSuspend y (InternalGet y e r w user m) where+  suspend = InternalGet $ \ sc r w sIn pcIn@(TopFrame ys pcInside) ->+    if checkBool pcInside -- Has Nothing ever been given to a partial continuation?+      then let f Nothing = let pcOut = TopFrame mempty (rememberFalse pcInside)+                           in sc False r w sIn pcOut+               f (Just bs') | L.null bs' = let pcOut = TopFrame mempty pcInside+                                           in sc True r w sIn pcOut+                            | otherwise = let sOut = appendBS sIn bs'+                                              pcOut = TopFrame mempty (addFuture bs' pcInside)+                                          in sc True r w sOut pcOut+           in return (IPartial ys (Right f))+      else sc False r w sIn pcIn  -- once Nothing has been given suspend is a no-op+   where appendBS s@(S {current=bs}) bs' = s { current=mappend bs bs' }+         -- addFuture puts the new data in 'future' where throwError's collect can find and use it+         addFuture _bs x@(ErrorFrame {}) = x+         addFuture bs x@(HandlerFrame {future_input=future, older_frame=pc}) =+           x { future_input=future |> bs, older_frame= addFuture bs pc }+         -- Once suspend is given Nothing, it remembers this and always returns False+         checkBool (HandlerFrame {older_frame=pc}) = checkBool pc+         checkBool (ErrorFrame {input_continues=b}) = b+         rememberFalse x@(ErrorFrame {}) = x { input_continues=False }+         rememberFalse x@(HandlerFrame {older_frame=pc}) = x { older_frame=rememberFalse pc }++  yieldItem y = InternalGet $ \sc r w s (TopFrame ys pc) ->+                  let ys' = ys |> y+                  in sc () r w s (TopFrame ys' pc)++  -- This does nothing when there are no items pending, otherwise it+  -- returns IPartial (Seq y) (Left ...)+  flushItems = InternalGet $ \sc r w s tf@(TopFrame ys pc) ->+                 if Data.Sequence.null ys then sc () r w s tf+                   else let lazy'rest = sc () r w s (TopFrame mempty pc)+                        in return (IPartial ys (Left lazy'rest))++  pendingItems = InternalGet $ \sc r w s pc@(TopFrame ys _pc) -> sc (Data.Sequence.length ys) r w s pc++          +-- A unique sort of command...++-- | 'discardInnerHandler' causes the most recent catchError to be+-- discarded, i.e. this reduces the stack of error handlers by removing+-- the top one.  These are the same handlers which Alternative((<|>)) and+-- MonadPlus(mplus) use.  This is useful to commit to the current branch and let+-- the garbage collector release the suspended handler and its hold on+-- the earlier input.+discardInnerHandler :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m ()+discardInnerHandler = InternalGet $ \ sc r w s (TopFrame ys pcIn) ->+  let pcOut = case pcIn of ErrorFrame {} -> pcIn+                           HandlerFrame _catcher _s _future pc' -> pc'+  in sc () r w s (TopFrame ys pcOut)+{-# INLINE discardInnerHandler #-}++-- The BinaryParser instance:++-- INTERNALS :+-- the getWord*,getPtr,getStorable functions call getByteString+-- getByteString works with the first strict bytestring if the request fits+--   otherwise it call getLazyByteString and allocates a new strict bytestring for the result+-- getLazyByteString calls splitAtOrDie and+--   on Nothing it suspends and if that returns True then it tries again else throwError+--   on Just it returns the desired length lazy bytestring result and advances the parser++-- | Discard the next @m@ bytes+skip :: ({-Show user,-} Error e, Monad m) => Int64 -> InternalGet y e r w user m ()+skip m | m <=0 = return ()+       | otherwise = do+  ensureBytes m+  (S ss bs n user) <- getFull+  case L.drop m (L.chunk ss bs) of+    L.Empty -> putFull (S mempty mempty (n+m) user)+    L.Chunk ss' bs' -> putFull (S ss' bs' (n+m) user)++-- | Return the number of 'bytesRead' so far.  Initially 0, never negative.+bytesRead :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Int64+bytesRead = fmap consumed getFull++-- | 'remaining' returns the number of bytes available before the+-- current input runs out and 'suspend' might be called (this is the+-- length of the lazy bytestring returned by 'getAvailable').  If this+-- is preceded by 'suspendUntilComplete' then this will definitely by+-- the complete length.+remaining :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Int64+remaining = do (S ss bs _n _user) <- getFull+               return $ fromIntegral (S.length ss) + (L.length bs)++-- | Return True if the number of bytes 'remaining' is 0.  Any futher+-- attempts to read an empty parser will cal 'suspend'.+isEmpty :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Bool+isEmpty = do (S ss bs _n _user) <- getFull+             return $ (S.null ss) && (L.null bs)++spanOf :: ({-Show user,-} Error e, Monad m) => (Word8 -> Bool) ->  InternalGet y e r w user m (L.ByteString)+spanOf f = do let loop = do (S ss bs n user) <- getFull+                            let (pre,post) = L.span f (L.chunk ss bs)+                            case post of+                              L.Empty -> putFull (S mempty mempty (n + L.length pre) user)+                              L.Chunk ss' bs' -> putFull (S ss' bs' (n + L.length pre) user)+                            if L.null post+                              then fmap ((L.toChunks pre)++) $ do+                                     continue <- suspend+                                     if continue then loop+                                       else return (L.toChunks pre)+                              else return (L.toChunks pre)+              fmap L.fromChunks loop+{-# INLINE spanOf #-}++-- | Pull @n@ bytes from the input, as a strict ByteString.  This will+-- suspend if there is too little data.  If the result spans multiple+-- lazy chunks then the result occupies a freshly allocated strict+-- bytestring, otherwise it fits in a single chunk and refers to the+-- same immutable memory block as the whole chunk.+getByteString :: ({-Show user,-} Error e, Monad m) => Int -> InternalGet y e r w user m S.ByteString+getByteString nIn = do+  (S ss bs n user) <- getFull+  if nIn < S.length ss+    then do let (pre,post) = S.splitAt nIn ss+            putFull (S post bs (n+fromIntegral nIn) user)+            return pre+    -- Expect nIn to be less than S.length ss the vast majority of times+    -- so do not worry about doing anything fancy here.+    else fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn))+{-# INLINE getByteString #-} -- important++getWordhost :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Word+getWordhost = getStorable+{-# INLINE getWordhost #-}++getWord8 :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Word8+getWord8 = getPtr 1+{-# INLINE getWord8 #-}++getWord16be,getWord16le,getWord16host :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Word16+getWord16be = do+    s <- getByteString 2+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w16` 8) .|.+              (fromIntegral (s `S.unsafeIndex` 1))+{-# INLINE getWord16be #-}+getWord16le = do+    s <- getByteString 2+    return $! (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord16le #-}+getWord16host = getStorable+{-# INLINE getWord16host #-}++getWord32be,getWord32le,getWord32host :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Word32+getWord32be = do+    s <- getByteString 4+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 3) )+{-# INLINE getWord32be #-}+getWord32le = do+    s <- getByteString 4+    return $! (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord32le #-}+getWord32host = getStorable+{-# INLINE getWord32host #-}+++getWord64be,getWord64le,getWord64host :: ({-Show user,-} Error e, Monad m) => InternalGet y e r w user m Word64+getWord64be = do+    s <- getByteString 8+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 7) )+{-# INLINE getWord64be #-}+getWord64le = do+    s <- getByteString 8+    return $! (fromIntegral (s `S.unsafeIndex` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord64le #-}+getWord64host = getStorable+{-# INLINE getWord64host #-}++instance ({-Show user,-} Error e, Monad m) => P.BinaryParser (InternalGet y e r w user m) where+  skip = skip . fromIntegral+  bytesRead = fmap fromIntegral bytesRead+  remaining = fmap fromIntegral remaining+  isEmpty = isEmpty+  spanOf = fmap (S.concat . L.toChunks) . spanOf++  getByteString = getByteString+  getWordhost = getWordhost+  getWord8 = getWord8++  getWord16be = getWord16be+  getWord32be = getWord32be+  getWord64be = getWord64be++  getWord16le = getWord16le+  getWord32le = getWord32le+  getWord64le = getWord64le++  getWord16host = getWord16host+  getWord32host = getWord32host+  getWord64host = getWord64host++-- Below here are the class instances+    +instance ({-Show user,-} Error e, Monad m) => Functor (InternalGet y e r w user m) where+  fmap f m = InternalGet (\sc -> unInternalGet m (sc . f))+  {-# INLINE fmap #-}++instance ({-Show user,-} Monad m,Error e) => Monad (InternalGet y e r w user m) where+  return a = InternalGet (\sc -> sc a)+  {-# INLINE return #-}+  m >>= k  = InternalGet (\sc -> unInternalGet m (\a -> unInternalGet (k a) sc))+  {-# INLINE (>>=) #-}+  fail msg = throwError (strMsg msg)++instance MonadTrans (InternalGet y e r w user) where+  lift m = InternalGet (\sc r w s pc -> m >>= \a -> sc a r w s pc)++instance ({-Show user,-} MonadIO m,Error e) => MonadIO (InternalGet y e r w user m) where+  liftIO = lift . liftIO++instance ({-Show user,-} Monad m,Error e) => MonadError e (InternalGet y e r w user m) where+  throwError msg = InternalGet $ \_sc _r _w s tf@(TopFrame ys pcIn) ->+    let go (ErrorFrame ec _b) = ec s tf msg+        go (HandlerFrame (Just catcher) s1 future pc1) = catcher (collect s1 future) (TopFrame ys pc1) msg+        go (HandlerFrame Nothing _s _future pc1) = go pc1+    in go pcIn++  catchError mayFail handler = InternalGet $ \scCaptured rCaptured wCaptured s (TopFrame ys pc) ->+    let pcWithHandler = let catcher s1 pc1 e1 = unInternalGet (handler e1) scCaptured rCaptured wCaptured s1 pc1+                        in TopFrame ys (HandlerFrame (Just catcher) s mempty pc)+        actionWithCleanup = mayFail >>= \a -> discardInnerHandler >> return a+    in unInternalGet actionWithCleanup scCaptured rCaptured wCaptured s pcWithHandler++instance ({-Show user,-} Monad m, Error e, Monoid w) => MonadWriter w (InternalGet y e r w user m) where+  tell w'  = InternalGet (\sc r w -> sc () r (mappend w w'))+  listen m = InternalGet (\sc r w -> let sc' a r' w'= sc (a,w') r' (mappend w w')+                                     in unInternalGet m sc' r mempty)+  pass m   = InternalGet (\sc r w s pc -> let sc' (a,f) r' w' s' pc' = sc a r' (mappend w (f w')) s' pc'+                                          in unInternalGet m sc' r mempty s pc)++instance ({-Show user,-} Monad m, Error e) => MonadReader r (InternalGet y e r w user m) where+  ask = InternalGet (\sc r -> sc r r)+  local f m = InternalGet (\sc r -> let sc' a _r = sc a r+                              in unInternalGet m sc' (f r))+              +instance ({-Show user,-} Monad m,Error e) => MonadState user (InternalGet y e r w user m) where+  get   = InternalGet (\sc r w s -> sc (user_field s) r w s)+  put u = InternalGet (\sc r w s -> let s' = s {user_field=u}+                              in sc () r w s')++instance ({-Show user,-} Monad m, Error e) => MonadPlus (InternalGet y e r w user m) where+  mzero = throwError noMsg+  mplus m1 m2 = catchError m1 (const m2)++instance ({-Show user,-} Monad m,Error e) => Applicative (InternalGet y e r w user m) where+  pure = return+  (<*>) = ap++instance ({-Show user,-} Monad m,Error e) => Alternative (InternalGet y e r w user m) where+  empty = mzero+  (<|>) = mplus++-- | I use splitAt without tolerating too few bytes, so write a Maybe version.+-- This is the only place I invoke L.Chunk as constructor instead of pattern matching.+-- I claim that the first argument cannot be empty.+splitAtOrDie :: Int64 -> L.ByteString -> Maybe (L.ByteString, L.ByteString)+splitAtOrDie i ps | i <= 0 = Just (L.Empty, ps)+splitAtOrDie _i L.Empty = Nothing+splitAtOrDie i (L.Chunk x xs) | i < len = let (pre,post) = S.splitAt (fromIntegral i) x+                                          in Just (L.Chunk pre L.Empty+                                                  ,L.Chunk post xs)+                              | otherwise = case splitAtOrDie (i-len) xs of+                                              Nothing -> Nothing+                                              Just (y1,y2) -> Just (L.Chunk x y1,y2)+  where len = fromIntegral (S.length x)+{-# INLINE splitAtOrDie #-}++-- getPtr copied from binary's Get.hs+------------------------------------------------------------------------+-- Primtives++-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString. So many indirections from the raw parser+-- state that my head hurts...++getPtr :: ({-Show user,-} Error e, Monad m,Storable a) => Int -> InternalGet y e r w user m a+getPtr n = do+    (fp,o,_) <- fmap S.toForeignPtr (getByteString n)+    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getPtr #-}++getStorable :: forall y e r w user m a. ({-Show user,-} Error e, Monad m,Storable a) => InternalGet y e r w user m a+getStorable = do+    (fp,o,_) <- fmap S.toForeignPtr (getByteString (sizeOf (undefined :: a)))+    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getStorable #-}++-- Unchecked shifts copied from binary's Get.hs+------------------------------------------------------------------------+------------------------------------------------------------------------+-- Unchecked shifts++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++#if __GLASGOW_HASKELL__ <= 606+-- Exported by GHC.Word in GHC 6.8 and higher+foreign import ccall unsafe "stg_uncheckedShiftL64"+    uncheckedShiftL64#     :: Word64# -> Int# -> Word64#+#endif++#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif+++------------------------------------------------------------------------+{- TESTING -}+------------------------------------------------------------------------++chomp :: CompGet y () String () IO ()+chomp = getByteString 1 >>= \w -> tell (map (toEnum . fromEnum) (S.unpack w))++feed :: (Monad t) => Word8 -> CompResult y t1 t2 t t3 -> t (CompResult y t1 t2 t t3)+feed x (CPartial _ys (Left q)) = q+feed x (CPartial _ys (Right q)) = q (Just (L.pack [x]))+feed _x y = return y++test :: (Monoid w, Monad m) => CompGet y () w () m a -> [Word8] -> m (CompResult y w () m a)+test g bs = runCompGet g () () (L.pack bs)++test10 :: IO (CompResult () String () IO [()])+test10 = test (mplus (pr "go" >> replicateM 5 chomp >> pr "die" >> mzero) (pr "reborn" >> replicateM 10 chomp)) [1] >>= feed 2 >>= feed 3 >>= feed 4 >>= feed 5 >>= feed 6 >>= feed 7 >>=feed 8 >>= feed 9 >>= feed 10++pr :: (MonadIO m, Show a) => a -> m ()+pr = liftIO . Prelude.print++countPC :: ({-Show user,-} Monad m) => CompGet y r w user m Int+countPC = InternalGet $ \ sc r w s (TopFrame ys pc) ->+  let go (ErrorFrame {}) i = i+      go (HandlerFrame _ _ _ pc') i = go pc' $! succ i+  in sc (go pc 0) r w s (TopFrame ys pc)++{- testDepth result on my machine:++*Text.ProtocolBuffers.MyGet> testDepth+("stack depth",0,"bytes read",0,"bytes remaining",0,"begin")+("feed1",[48,49])+("stack depth",1,"bytes read",1,"bytes remaining",1,"mayFail")+("stack depth",2,"bytes read",1,"bytes remaining",1,"depth2")+("feed1",[50,51])+("stack depth",2,"bytes read",4,"bytes remaining",0,"about to mzero")+("stack depth",1,"bytes read",1,"bytes remaining",3,"middle")+("stack depth",1,"bytes read",2,"bytes remaining",2,"about to mzero again")+("stack depth",0,"bytes read",1,"bytes remaining",3,"handler")+("feed1",[52,53])+("feed1",[54,55])+("stack depth",0,"bytes read",7,"bytes remaining",1,"got 6, now suspendUntilComplete")+("feed1",[56,57])+("feed1",[58,59])+("feed1",[60,61])+("stack depth",0,"bytes read",7,"bytes remaining",7,"end")+(CFinished (Chunk "7" (Chunk "89" (Chunk ":;" (Chunk "<=" Empty)))) 7 ("0") (()) ("123456"))++The first chomp tell's "0".+All other tell's are thrown away by the error handling.+The stack depth returns to 0 as it should.+The "bytes read" is reset along with the input on each throwError/mzero/fail.+The (getByteString 6) reads "123456", leaving the "7" chunk on the input.+suspendUntilComplete loads the rest of the "89" ":;" and "<=" chunks.++-}++-- Ensure the stack fixing in catchError play words well:+testDepth :: IO (CompResult () String () IO S.ByteString)+testDepth = test depth [] >>= feed12 >>= feedNothing where+  p s = countPC >>= \d -> bytesRead >>= \ b -> remaining >>= \r ->+         pr ("stack depth",d,"bytes read",b,"bytes remaining",r,s)+  depth = do+    p "begin"+    chomp+    catchError ( p "mayFail" >>+                 ((p "depth2" >> replicateM 3 chomp >> p "about to mzero" >> mzero) <|> return ()) >>+                 p "middle" >>+                 chomp >> p "about to mzero again" >> mzero)+               (\_ -> p "handler")+    a <- getByteString 6+    p "got 6, now suspendUntilComplete"+    suspendUntilComplete+    p "end"+    return a++feed12 :: CompResult y w user IO a -> IO (CompResult y w user IO a)+feed12 = foldr1 (>=>) . map feeds $ [ [2*i,2*i+1]  | i <- [24..30]]+  where feeds x (CPartial _ys (Right q)) = print ("feed1",x)  >> q (Just (L.pack x))+        feeds x (CPartial _ys (Left q)) = print ("feed1 - no request")  >> q+        feeds _x y = return y++feedNothing :: (Monad t) => CompResult y t1 t2 t t3 -> t (CompResult y t1 t2 t t3)+feedNothing (CPartial _ys (Right q)) = q Nothing+feedNothing (CPartial _ys (Left q)) = q+feedNothing x = return x
+ Text/ProtocolBuffers/MyGetSimplified.hs view
@@ -0,0 +1,719 @@+{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,MultiParamTypeClasses,TypeSynonymInstances,RankNTypes #-}+--+-- By Chris Kuklewicz, drawing heavily from binary and binary-strict,+-- but all the bugs are my own.+--+-- This file is under the usual BSD3 licence, copyright 2008.+--+-- There is a streamlined version of MyGet.hs+--+-- This started out as an improvement to+-- Data.Binary.Stric.IncrementalGet with slightly better internals.+-- The simplified 'Get', 'runGet', 'Result' trio with the+-- 'Data.Binary.Strict.Class.BinaryParser' instance are an _untested_+-- upgrade from IncrementalGet.  Especially untested are the+-- strictness properties.+--+-- 'Get' usefully implements Applicative and Monad, MonadError,+-- Alternative and MonadPlus.  Unhandled errors are reported along+-- with the number of bytes successfully consumed.  Effects of+-- 'suspend' and 'putAvailable' are visible after+-- fail/throwError/mzero.+--+-- Each time the parser reaches the end of the input it will return a+-- Partial wrapped continuation which requests a (Maybe+-- Lazy.ByteString).  Passing (Just bs) will append bs to the input so+-- far and continue processing.  If you pass Nothing to the+-- continuation then you are declaring that there will never be more+-- input and that the parser should never again return a partial+-- contination; it should return failure or finished.+--+-- 'suspendUntilComplete' repeatedly uses a partial continuation to+-- ask for more input until Nothing is passed and then it proceeds+-- with parsing.+--+-- The 'getAvailable' command returns the lazy byte string the parser+-- has remaining before calling 'suspend'.  The 'putAvailable'+-- replaces this input and is a bit fancy: it also replaces the input+-- at the current offset for all the potential catchError/mplus+-- handlers.  This change is _not_ reverted by fail/throwError/mzero.+--+-- The three 'lookAhead' and 'lookAheadM' and 'lookAheadE' functions are+-- the same as the ones in binary's Data.Binary.Get.+--+module Text.ProtocolBuffers.MyGet+    (Get,runGet,Result(..)+     -- main primitives+    ,ensureBytes,getStorable,getLazyByteString,suspendUntilComplete+     -- parser state manipulation+    ,getAvailable,putAvailable+     -- lookAhead capabilities+    ,lookAhead,lookAheadM,lookAheadE+     -- below is for implementation of BinaryParser (for Int64 and Lazy bytestrings)+    ,skip,bytesRead,isEmpty,remaining,spanOf+    ,getWord8,getByteString+    ,getWord16be,getWord32be,getWord64be+    ,getWord16le,getWord32le,getWord64le+    ,getWordhost,getWord16host,getWord32host,getWord64host+    ) where++-- The Get monad is an instance of binary-strict's BinaryParser:+import qualified Data.Binary.Strict.Class as P(BinaryParser(..))+-- The Get monad is an instance of all of these library classes:+import Control.Applicative(Applicative(pure,(<*>)),Alternative(empty,(<|>)))+import Control.Monad(MonadPlus(mzero,mplus))+import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg))+-- It can be a MonadCont, but the semantics are too broken without a ton of work.++-- implementation imports+import Control.Monad(ap)                             -- instead of Functor.fmap; ap for Applicative+import Control.Monad(replicateM,(>=>))               -- XXX testing+import Data.Bits(Bits((.|.)))+import qualified Data.ByteString as S(concat,length,null,splitAt)+import qualified Data.ByteString as S(unpack) -- XXX testing+import qualified Data.ByteString.Internal as S(ByteString,toForeignPtr,inlinePerformIO)+import qualified Data.ByteString.Unsafe as S(unsafeIndex)+import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null)+import qualified Data.ByteString.Lazy as L(pack) -- XXX testing+import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk)+import qualified Data.Foldable as F(foldr,foldr1)    -- used with Seq+import Data.Int(Int64)                               -- index type for L.ByteString+import Data.Monoid(Monoid(mempty,mappend))           -- Writer has a Monoid contraint+import Data.Sequence(Seq,null,(|>))                  -- used for future queue in handler state+import Data.Word(Word,Word8,Word16,Word32,Word64)+import Foreign.ForeignPtr(withForeignPtr)+import Foreign.Ptr(castPtr,plusPtr)+import Foreign.Storable(Storable(peek,sizeOf))+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base(Int(..),uncheckedShiftL#)+import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#)+#endif++-- Simple external return type+data Result a = Failed {-# UNPACK #-} !Int64 String+              | Finished {-# UNPACK #-} !L.ByteString {-# UNPACK #-} !Int64 a+              | Partial (Maybe L.ByteString -> Result a)++-- Internal state type, not exposed to the user.+data S = S { top :: {-# UNPACK #-} !S.ByteString+           , current :: {-# UNPACK #-} !L.ByteString+           , consumed :: {-# UNPACK #-} !Int64+           } deriving Show++-- Private Internal error handling stack type+-- This must NOT be exposed by this module+--+-- The ErrorFrame is the top-level error handler setup when execution begins.+-- It starts with the Bool set to True: meaning suspend can ask for more input.+-- Once suspend get 'Nothing' in reply the Bool is set to False, which means+-- that 'suspend' should no longer ask for input -- the input is finished.+-- Why store the Bool there?  It was handy when I needed to add it.+data FrameStack b = ErrorFrame (String -> S -> Result b) -- top level handler+                               Bool -- True at start, False if Nothing passed to suspend continuation+                  | HandlerFrame (Maybe ( S -> FrameStack b -> String -> Result b ))  -- encapsulated handler+                                 S  -- stored state to pass to handler+                                 (Seq L.ByteString)  -- additional input to hass to handler+                                 (FrameStack b)  -- earlier/deeper/outer handlers+                  | FutureFrame S (Seq L.ByteString) (FrameStack b) -- for look ahead++type Success b a = (a -> S -> FrameStack b -> Result b)++-- Internal monad type+newtype Get a = Get {+  unGet :: forall b.    -- the forall hides the CPS style (and prevents use of MonadCont)+           Success b a  -- main continuation+        -> S            -- parser state+        -> FrameStack b -- error handler stack+        -> Result b     -- operation+    }++-- These implement the checkponting needed to store and revive the+-- state for lookAhead.  They are fragile because the setCheckpoint+-- must preceed either useCheckpoint or clearCheckpoint but not both.+-- The FutureFrame must be the most recent handler, so the commands+-- must be in the same scope depth.  Because of these constraints, the reader+-- value 'r' does not need to be stored and can be taken from the Get+-- parameter.+--+-- IMPORTANT: Any FutureFrame at the top level(s) is discarded by throwError.+setCheckpoint,useCheckpoint,clearCheckpoint :: Get ()+setCheckpoint = Get $ \ sc s pc -> sc () s (FutureFrame s mempty pc)+useCheckpoint = Get $ \ sc (S _ _ _) (FutureFrame s future pc) ->+  let (S ss bs n) = collect s future+  in sc () (S ss bs n) pc+clearCheckpoint = Get $ \ sc s (FutureFrame _s _future pc) -> sc () s pc++-- | 'lookAhead' runs the @todo@ action and then rewinds only the+-- BinaryParser state.  Any new input from 'suspend' or changes from+-- 'putAvailable' are kept.  Changes to the user state (MonadState)+-- are kept.  The MonadWriter output is retained.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAhead :: Get a -> Get a+lookAhead todo = do+  setCheckpoint+  a <- todo+  useCheckpoint+  return a++-- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the +-- BinaryParser state is rewound (as in 'lookAhead').  If the action return 'Just' then+-- the BinaryParser is not rewound, and lookAheadM acts as an identity.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAheadM :: Get (Maybe a) -> Get (Maybe a)+lookAheadM todo = do+  setCheckpoint+  a <- todo+  maybe useCheckpoint (\_ -> clearCheckpoint) a+  return a++-- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the +-- BinaryParser state is rewound (as in 'lookAhead').  If the action return 'Right' then+-- the BinaryParser is not rewound, and lookAheadE acts as an identity.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAheadE :: Get (Either a b) -> Get (Either a b)+lookAheadE todo = do+  setCheckpoint+  a <- todo+  either (\_ -> useCheckpoint) (\_ -> clearCheckpoint) a+  return a++-- 'collect' is used by 'putCheckpoint' and 'throwError'+collect :: S -> Seq L.ByteString -> S+collect s@(S ss bs n) future | Data.Sequence.null future = s+                             | otherwise = S ss (mappend bs (F.foldr1 mappend future)) n++-- Put the Show instances here++instance (Show a) => Show (Result a) where+  showsPrec _ (Failed n msg) = ("(Failed "++) . shows n . (' ':) . shows msg . (")"++)+  showsPrec _ (Finished bs n a) =+    ("(CFinished ("++) +    . shows bs . (") ("++)+    . shows n . (") ("++) +    . shows a . ("))"++)+  showsPrec _ (Partial {}) = ("(Partial <Maybe Data.ByteString.Lazy.ByteString-> Result a)"++)++instance Show (FrameStack b) where+  showsPrec _ (ErrorFrame _ p) =(++) "(ErrorFrame <e->s->m b> " . shows p . (")"++)+  showsPrec _ (HandlerFrame _ s future pc) = ("(HandlerFrame <> ("++)+                                     . shows s . (") ("++) . shows future . (") ("++)+                                     . shows pc . (")"++)+  showsPrec _ (FutureFrame s future pc) =  ("(FutureFrame <s->FrameStack b e s m->e->m b> ("++)+                                     . shows s . (") ("++) . shows future . (") ("++)+                                     . shows pc . (")"++)++-- | 'runGet' is the simple executor+runGet :: Get a -> L.ByteString -> Result a+runGet (Get f) bsIn = f scIn sIn (ErrorFrame ec True)+  where scIn a (S ss bs n) _pc = Finished (L.chunk ss bs) n a+        sIn = case bsIn of L.Empty -> S mempty mempty 0+                           L.Chunk ss bs -> S ss bs 0+        ec msg sOut = Failed (consumed sOut) msg++-- | Get the input currently available to the parser.+getAvailable :: Get L.ByteString+getAvailable = Get $ \ sc s@(S ss bs _) pc -> sc (L.chunk ss bs) s pc++-- | 'putAvailable' replaces the bytestream past the current # of read+-- bytes.  This will also affect pending MonadError handler and+-- MonadPlus branches.  I think all pending branches have to have+-- fewer bytesRead than the current one.  If this is wrong then an+-- error will be thrown.+--+-- WARNING : 'putAvailable' is still untested.+putAvailable :: L.ByteString -> Get ()+putAvailable bsNew = Get $ \ sc (S _ss _bs n) pc ->+  let s' = case bsNew of+             L.Empty -> S mempty mempty n+             L.Chunk ss' bs' -> S ss' bs' n+      rebuild (HandlerFrame catcher (S ss1 bs1 n1) future pc') =+               HandlerFrame catcher sNew mempty (rebuild pc')+        where balance = n - n1+              whole | balance < 0 = error "Impossible? Cannot rebuild HandlerFrame in MyGet.putAvailable: balance is negative!"+                    | otherwise = L.take balance $ L.chunk ss1 bs1 `mappend` F.foldr mappend mempty future+              sNew | balance /= L.length whole = error "Impossible? MyGet.putAvailable.rebuild.sNew HandlerFrame assertion failed."+                   | otherwise = case mappend whole bsNew of+                                   L.Empty -> S mempty mempty n1+                                   L.Chunk ss2 bs2 -> S ss2 bs2 n1+      rebuild (FutureFrame (S ss1 bs1 n1) future pc') =+               FutureFrame sNew mempty (rebuild pc')+        where balance = n - n1+              whole | balance < 0 = error "Impossible? Cannot rebuild FutureFrame in MyGet.putAvailable: balance is negative!"+                    | otherwise = L.take balance $ L.chunk ss1 bs1 `mappend` F.foldr mappend mempty future+              sNew | balance /= L.length whole = error "Impossible? MyGet.putAvailable.rebuild.sNew FutureFrame assertion failed."+                   | otherwise = case mappend whole bsNew of+                                   L.Empty -> S mempty mempty n1+                                   L.Chunk ss2 bs2 -> S ss2 bs2 n1+      rebuild x@(ErrorFrame {}) = x+  in sc () s' (rebuild pc)++-- Internal access to full internal state, as helepr functions+getFull :: Get S+getFull = Get $ \ sc s pc -> sc s s pc+putFull :: S -> Get ()+putFull s = Get $ \ sc _s pc -> sc () s pc++-- | Keep calling 'suspend' until Nothing is passed to the 'Partial'+-- continuation.  This ensures all the data has been loaded into the+-- state of the parser.+suspendUntilComplete :: Get ()+suspendUntilComplete = do+  continue <- suspend+  if continue then suspendUntilComplete+    else return ()++-- | Call suspend and throw and error with the provided @msg@ if+-- Nothing has been passed to the 'Partial' continuation.  Otherwise+-- return ().+suspendMsg :: String -> Get ()+suspendMsg msg = do continue <- suspend+                    if continue then return ()+                      else throwError msg++-- | check that there are at least @n@ bytes available in the input.+-- This will suspend if there is to little data.+ensureBytes :: Int64 -> Get ()+ensureBytes n = do+  (S ss bs _read) <- getFull+  if n < fromIntegral (S.length ss)+    then return ()+    else do if n == L.length (L.take n (L.chunk ss bs))+              then return ()+              else suspendMsg "ensureBytes failed" >> ensureBytes n+{-# INLINE ensureBytes #-}++-- | Pull @n@ bytes from the unput, as a lazy ByteString.  This will+-- suspend if there is too little data.+getLazyByteString :: Int64 -> Get L.ByteString+getLazyByteString n | n<=0 = return mempty+                    | otherwise = do+  (S ss bs offset) <- getFull+  case splitAtOrDie n (L.chunk ss bs) of+    Just (consume,rest) ->do+       case rest of+         L.Empty -> putFull (S mempty mempty (offset + n))+         L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n))+       return consume+    Nothing -> suspendMsg "getLazyByteString failed" >> getLazyByteString n+{-# INLINE getLazyByteString #-} -- important++-- | 'suspend' is supposed to allow the execution of the monad to be+-- halted, awaiting more input.  The computation is supposed to+-- continue normally if this returns True, and is supposed to halt+-- without calling suspend again if this returns False.  All future+-- calls to suspend will return False automatically and no nothing+-- else.+--+-- These semantics are too specialized to let this escape this module.+class MonadSuspend m where+  suspend :: m Bool++-- The instance here is fairly specific to the stack manipluation done+-- by 'addFuture' to ('S' user) and to the packaging of the resumption+-- function in 'IResult'('IPartial').+instance MonadSuspend Get where+    suspend = Get $ \ sc sIn pcIn ->+      if checkBool pcIn -- Has Nothing ever been given to a partial continuation?+        then let f Nothing = let pcOut = rememberFalse pcIn+                             in sc False sIn pcOut+                 f (Just bs') = let sOut = appendBS sIn bs'+                                    pcOut = addFuture bs' pcIn+                                in sc True sOut pcOut+             in Partial f+        else sc False sIn pcIn  -- once Nothing has been given suspend is a no-op+     where appendBS (S ss bs n) bs' = S ss (mappend bs bs') n+           -- addFuture puts the new data in 'future' where throwError's collect can find and use it+           addFuture bs (HandlerFrame catcher s future pc) =+                         HandlerFrame catcher s (future |> bs) (addFuture bs pc)+           addFuture bs (FutureFrame s future pc) =+                         FutureFrame s (future |> bs) (addFuture bs pc)+           addFuture _bs x@(ErrorFrame {}) = x+           -- Once suspend is given Nothing, it remembers this and always returns False+           checkBool (ErrorFrame _ b) = b+           checkBool (HandlerFrame _ _ _ pc) = checkBool pc+           checkBool (FutureFrame _ _ pc) = checkBool pc+           rememberFalse (ErrorFrame ec _) = ErrorFrame ec False+           rememberFalse (HandlerFrame catcher s future pc) =+                          HandlerFrame catcher s future (rememberFalse pc)+           rememberFalse (FutureFrame s future pc) =+                          FutureFrame s future (rememberFalse pc)+          +-- A unique sort of command...++-- | 'discardInnerHandler' causes the most recent catchError to be+-- discarded, i.e. this reduces the stack of error handlers by removing+-- the top one.  These are the same handlers which Alternative((<|>)) and+-- MonadPlus(mplus) use.  This is useful to commit to the current branch and let+-- the garbage collector release the suspended handler and its hold on+-- the earlier input.+discardInnerHandler :: Get ()+discardInnerHandler = Get $ \ sc s pcIn ->+  let pcOut = case pcIn of ErrorFrame {} -> pcIn+                           HandlerFrame _ _ _ pc' -> pc'+                           FutureFrame _ _ pc' -> pc'+  in sc () s pcOut+{-# INLINE discardInnerHandler #-}++{- Currently unused, commented out to satisfy -Wall++-- | 'discardAllHandlers' causes all catchError handler to be+-- discarded, i.e. this reduces the stack of error handlers to the top+-- level handler.  These are the same handlers which Alternative((<|>))+-- and MonadPlus(mplus) use.  This is useful to commit to the current+-- branch and let the garbage collector release the suspended handlers+-- and their hold on the earlier input.+discardAllHandlers :: Get ()+discardAllHandlers = Get $ \ sc s pcIn ->+  let base pc@(ErrorFrame {}) = pc+      base (HandlerFrame _ _ _ pc) = base pc+      base (FutureFrame _ _ pc) = base pc+  in sc () s (base pcIn)+{-# INLINE discardAllHandlers #-}+-}+-- The BinaryParser instance:++-- | Discard the next @m@ bytes+skip :: Int64 -> Get ()+skip m | m <=0 = return ()+       | otherwise = do+  ensureBytes m+  (S ss bs n) <- getFull+  case L.drop m (L.chunk ss bs) of+    L.Empty -> putFull (S mempty mempty (n+m))+    L.Chunk ss' bs' -> putFull (S ss' bs' (n+m))++-- | Return the number of 'bytesRead' so far.  Initially 0, never negative.+bytesRead :: Get Int64+bytesRead = fmap consumed getFull++-- | Return the number of bytes 'remaining' before the current input+-- runs out and 'suspend' might be called.+remaining :: Get Int64+remaining = do (S ss bs _) <- getFull+               return $ fromIntegral (S.length ss) + (L.length bs)++-- | Return True if the number of bytes 'remaining' is 0.  Any futher+-- attempts to read an empty parser will cal 'suspend'.+isEmpty :: Get Bool+isEmpty = do (S ss bs _n) <- getFull+             return $ (S.null ss) && (L.null bs)++spanOf :: (Word8 -> Bool) ->  Get (L.ByteString)+spanOf f = do let loop = do (S ss bs n) <- getFull+                            let (pre,post) = L.span f (L.chunk ss bs)+                            case post of+                              L.Empty -> putFull (S mempty mempty (n + L.length pre))+                              L.Chunk ss' bs' -> putFull (S ss' bs' (n + L.length pre))+                            if L.null post+                              then fmap ((L.toChunks pre)++) $ do+                                     continue <- suspend+                                     if continue then loop+                                       else return (L.toChunks pre)+                              else return (L.toChunks pre)+              fmap L.fromChunks loop+{-# INLINE spanOf #-}++-- | Pull @n@ bytes from the input, as a strict ByteString.  This will+-- suspend if there is too little data.  If the result spans multiple+-- lazy chunks then the result occupies a freshly allocated strict+-- bytestring, otherwise it fits in a single chunk and refers to the+-- same immutable memory block as the whole chunk.+getByteString :: Int -> Get S.ByteString+getByteString nIn | nIn <= 0 = return mempty+                  | otherwise = do+  (S ss bs n) <- getFull+  if nIn < S.length ss+    then do let (pre,post) = S.splitAt nIn ss+            putFull (S post bs (n+fromIntegral nIn))+            return pre+    -- Expect nIn to be less than S.length ss the vast majority of times+    -- so do not worry about doing anything fancy here.+    else fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn))+{-# INLINE getByteString #-} -- important++getWordhost :: Get Word+getWordhost = getStorable+{-# INLINE getWordhost #-}++getWord8 :: Get Word8+getWord8 = getPtr 1+{-# INLINE getWord8 #-}++getWord16be,getWord16le,getWord16host :: Get Word16+getWord16be = do+    s <- getByteString 2+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w16` 8) .|.+              (fromIntegral (s `S.unsafeIndex` 1))+{-# INLINE getWord16be #-}+getWord16le = do+    s <- getByteString 2+    return $! (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord16le #-}+getWord16host = getStorable+{-# INLINE getWord16host #-}++getWord32be,getWord32le,getWord32host :: Get Word32+getWord32be = do+    s <- getByteString 4+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 3) )+{-# INLINE getWord32be #-}+getWord32le = do+    s <- getByteString 4+    return $! (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord32le #-}+getWord32host = getStorable+{-# INLINE getWord32host #-}+++getWord64be,getWord64le,getWord64host :: Get Word64+getWord64be = do+    s <- getByteString 8+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 7) )+{-# INLINE getWord64be #-}+getWord64le = do+    s <- getByteString 8+    return $! (fromIntegral (s `S.unsafeIndex` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord64le #-}+getWord64host = getStorable+{-# INLINE getWord64host #-}++instance P.BinaryParser Get where+  skip = skip . fromIntegral+  bytesRead = fmap fromIntegral bytesRead+  remaining = fmap fromIntegral remaining+  isEmpty = isEmpty+  spanOf = fmap (S.concat . L.toChunks) . spanOf++  getByteString = getByteString+  getWordhost = getWordhost+  getWord8 = getWord8++  getWord16be = getWord16be+  getWord32be = getWord32be+  getWord64be = getWord64be++  getWord16le = getWord16le+  getWord32le = getWord32le+  getWord64le = getWord64le++  getWord16host = getWord16host+  getWord32host = getWord32host+  getWord64host = getWord64host++-- Below here are the class instances+    +instance Functor Get where+  fmap f m = Get (\sc -> unGet m (sc . f))+  {-# INLINE fmap #-}++instance Monad Get where+  return a = Get (\sc -> sc a)+  {-# INLINE return #-}+  m >>= k  = Get (\sc -> unGet m (\a -> unGet (k a) sc))+  {-# INLINE (>>=) #-}+  fail msg = throwError (strMsg msg)++instance MonadError String Get where+  throwError msg = Get $ \_sc  s pcIn ->+    let go (ErrorFrame ec _) = ec msg s+        go (HandlerFrame catcher s1 future pc1) = catcher (collect s1 future) pc1 msg+        go (FutureFrame _ _ pc1) = go pc1 -- discard FutureFrame(s) between inner scope and a handler or error frame+    in go pcIn++  catchError mayFail handler = Get $ \sc s pc ->+    let pcWithHandler = let catcher s1 pc1 e1 = unGet (handler e1) sc s1 pc1+                        in HandlerFrame catcher s mempty pc+        actionWithCleanup = mayFail >>= \a -> discardInnerHandler >> return a+    in unGet actionWithCleanup sc s pcWithHandler++instance MonadPlus Get where+  mzero = throwError (strMsg "[mzero:no message]")+  mplus m1 m2 = catchError m1 (const m2)++instance Applicative Get where+  pure = return+  (<*>) = ap++instance Alternative Get where+  empty = mzero+  (<|>) = mplus++-- | I use "splitAt" without tolerating too few bytes, so write a Maybe version.+-- This is the only place I invoke L.Chunk as constructor instead of pattern matching.+-- I claim that the first argument cannot be empty.+splitAtOrDie :: Int64 -> L.ByteString -> Maybe (L.ByteString, L.ByteString)+splitAtOrDie i ps | i <= 0 = Just (L.Empty, ps)+splitAtOrDie _i L.Empty = Nothing+splitAtOrDie i (L.Chunk x xs) | i < len = let (pre,post) = S.splitAt (fromIntegral i) x+                                          in Just (L.Chunk pre L.Empty+                                                  ,L.Chunk post xs)+                              | otherwise = case splitAtOrDie (i-len) xs of+                                              Nothing -> Nothing+                                              Just (y1,y2) -> Just (L.Chunk x y1,y2)+  where len = fromIntegral (S.length x)+{-# INLINE splitAtOrDie #-}++------------------------------------------------------------------------+-- getPtr copied from binary's Get.hs++-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString. So many indirections from the raw parser+-- state that my head hurts...++getPtr :: (Storable a) => Int -> Get a+getPtr n = do+    (fp,o,_) <- fmap S.toForeignPtr (getByteString n)+    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getPtr #-}++-- I pushed the sizeOf into here (uses ScopedTypeVariables)+getStorable :: forall a. (Storable a) => Get a+getStorable = do+    (fp,o,_) <- fmap S.toForeignPtr (getByteString (sizeOf (undefined :: a)))+    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getStorable #-}++------------------------------------------------------------------------+------------------------------------------------------------------------+-- Unchecked shifts copied from binary's Get.hs++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++#if __GLASGOW_HASKELL__ <= 606+-- Exported by GHC.Word in GHC 6.8 and higher+foreign import ccall unsafe "stg_uncheckedShiftL64"+    uncheckedShiftL64#     :: Word64# -> Int# -> Word64#+#endif++#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif++{-+------------------------------------------------------------------------+{- TESTING:  This predate conversion to Simplified form -}+------------------------------------------------------------------------++chomp :: Get () String () IO ()+chomp = getByteString 1 >>= \w -> tell (map (toEnum . fromEnum) (S.unpack w))++feed :: (Monad t) => Word8 -> CompResult t1 t2 t t3 -> t (CompResult t1 t2 t t3)+feed x (CPartial q) = q (Just (L.pack [x]))+feed _x y = return y++test :: Get a -> [Word8] -> Result a+test g bs = runGet g () () (L.pack bs)++test10 :: IO (CompResult String () IO [()])+test10 = test (mplus (pr "go" >> replicateM 5 chomp >> pr "die" >> mzero) (pr "reborn" >> replicateM 10 chomp)) [1] >>= feed 2 >>= feed 3 >>= feed 4 >>= feed 5 >>= feed 6 >>= feed 7 >>=feed 8 >>= feed 9 >>= feed 10++pr :: (Show a) => a -> Get () String () IO ()+pr = liftIO . Prelude.print++countPC :: ({-Show user,-} Monad m) => Get Int+countPC = Get $ \ sc s pc ->+  let go (ErrorFrame {}) i = i+      go (HandlerFrame _ _ _ pc') i = go pc' $! succ i+      go (FutureFrame _ _ pc') i = go pc' $! succ i+  in sc (go pc 0) s pc++{- testDepth result on my machine:++*Text.ProtocolBuffers.MyGet> testDepth+("stack depth",0,"bytes read",0,"bytes remaining",0,"begin")+("feed1",[48,49])+("stack depth",1,"bytes read",1,"bytes remaining",1,"mayFail")+("stack depth",2,"bytes read",1,"bytes remaining",1,"depth2")+("feed1",[50,51])+("stack depth",2,"bytes read",4,"bytes remaining",0,"about to mzero")+("stack depth",1,"bytes read",1,"bytes remaining",3,"middle")+("stack depth",1,"bytes read",2,"bytes remaining",2,"about to mzero again")+("stack depth",0,"bytes read",1,"bytes remaining",3,"handler")+("feed1",[52,53])+("feed1",[54,55])+("stack depth",0,"bytes read",7,"bytes remaining",1,"got 6, now suspendUntilComplete")+("feed1",[56,57])+("feed1",[58,59])+("feed1",[60,61])+("stack depth",0,"bytes read",7,"bytes remaining",7,"end")+(CFinished (Chunk "7" (Chunk "89" (Chunk ":;" (Chunk "<=" Empty)))) 7 ("0") (()) ("123456"))++The first chomp tell's "0".+All other tell's are thrown away by the error handling.+The stack depth returns to 0 as it should.+The "bytes read" is reset along with the input on each throwError/mzero/fail.+The (getByteString 6) reads "123456", leaving the "7" chunk on the input.+suspendUntilComplete loads the rest of the "89" ":;" and "<=" chunks.++-}++-- Ensure the stack fixing in catchError play words well:+testDepth :: IO (CompResult String () IO S.ByteString)+testDepth = test depth [] >>= feed12 >>= feedNothing where+  p s = countPC >>= \d -> bytesRead >>= \ b -> remaining >>= \r ->+         pr ("stack depth",d,"bytes read",b,"bytes remaining",r,s)+  depth = do+    p "begin"+    chomp+    catchError ( p "mayFail" >>+                 ((p "depth2" >> replicateM 3 chomp >> p "about to mzero" >> mzero) <|> return ()) >>+                 p "middle" >>+                 chomp >> p "about to mzero again" >> mzero)+               (\_ -> p "handler")+    a <- getByteString 6+    p "got 6, now suspendUntilComplete"+    suspendUntilComplete+    p "end"+    return a++feed12 :: CompResult w user IO a -> IO (CompResult w user IO a)+feed12 = foldr1 (>=>) . map feeds $ [ [2*i,2*i+1]  | i <- [24..30]]+  where feeds x (CPartial q) = print ("feed1",x)  >> q (Just (L.pack x))+        feeds _x y = return y++feedNothing :: (Monad t) => CompResult t1 t2 t t3 -> t (CompResult t1 t2 t t3)+feedNothing (CPartial q) = q Nothing+feedNothing x = return x+-}
+ Text/ProtocolBuffers/MyGetW.hs view
@@ -0,0 +1,1078 @@+{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,MultiParamTypeClasses,TypeSynonymInstances,BangPatterns,FunctionalDependencies #-}+--+-- By Chris Kuklewicz, drawing heavily from binary and binary-strict.+-- but all the bugs are my own.+--+-- This file is under the usual BSD3 licence, copyright 2008.+--+-- There is a sibling to this module (once called "MyGet") that does not have+-- the MonadCont instances or machinery, and hides the "b" type variable with+-- a forall.+--+-- This started out as an improvement to Data.Binary.Strict.IncrementalGet with+-- slightly better internals.  The simplified "get,runGet,Result" trio with the+-- 'Data.Binary.Strict.Class.BinaryParser' instance are an _untested_+-- upgrade from IncrementalGet.  Especially untested are the+-- strictness properties.+--+-- 'Get' implements usefully Applicative and Monad, MonadError,+-- Alternative and MonadPlus, and MonadCont.+-- +-- The 'CompGet' monad transformer has those and also useful MonadRead,+-- MonadWriter, and MonadState implementations.  Output to the writer+-- and changes to the State are thrown away when fail/throwError/mzero+-- is called.+-- +-- The semantics of throwError interating with MonadState and+-- MonadWriter and BinaryParser: an error reverts all changes to the+-- state and drops all items tell'd.  The position in the input stream+-- is rewound, but all items gotten from 'suspend' are kept.  Any+-- changes from 'putAvailable' are kept.  Thus throwError aborts any+-- 'listen' or 'pass' contexts.+--+-- Using a continuation from callCC does restore the reader and writer+-- environment and value to that present when callCC was used.  Thus+-- holding a continuation keeps the old reader and writer values+-- alive. Using a continuation does not restore the BinaryParser input+-- or the user state.  Holding a continuation does not keep the older+-- values of these alive.  'callCC' has a very selective memory.+--+-- The semantics of callCC with catchError: If you leave the scope of+-- a catchError handler via a continuation then it counts as a+-- success and the handler is not run.  If you capture the continuation inside the scope+-- of a catchError handler and return to this later then one of two things will happen:+--   (*) If execution has never left the scope then there is no effect on the handler or scope.+--       Thus uses of callCC and its continuation wholly inside such a scope do not interfere+--       with MonadError.+--   (*) If execution has left the scope then the scope and its handler are reinstanted but+--       with the current MonadState and BinaryParser being the new checkpoint.+-- The net result of calling a continuation is to restore the same chain of error handlers+-- as existed when callCC captured it.  The oldest scopes which are still in effect are unchanged,+-- while newer scopes are restored with new checkpoint data.+--+-- The semantics of callCC with lookAhead*: Same behaviour as+-- catchError.  Leaving succeeds and returning reinstates the+-- lookAhead with the current input on return as fallback.+--+-- The semantics of callCC interating with MonadWriter are identical to (WriterT w (ContT r m)):+--    The writer state is captured by callCC and restored when resuming, discarding changes.+--    Any 'listen' and 'pass' contexts present when the continuation was captured are restored.+--    This avoids sorting out what to do about the aborted 'listen' and 'pass' contexts+--    at the site where the continuation was called.+-- Note that (ContT r (WriterT w m)) is NOT a MonadWriter instance in the library.+--+-- The semantics of callCC interating with MonadState and BinaryParser:+--    The state and input when a continuaton is called is kept, it is not restored to+--    the state and input present when the continuaton was captured by callCC.+--+-- Top level errors are reported along with number of bytes successfully consumed.+--+-- Each time the parser reaches the end of the input it will return a+-- Partial or CPartial Left-wrapped continuation which requests a+-- (Maybe Lazy.ByteString).  Passing (Just bs) will append bs to the+-- input so far.  If you pass Nothing to the continuation, then you+-- are declaring that there will never be more input and the parser+-- should never again return a partial contination; it should return+-- failure or finished.+--+-- The newest feaature is the ability for the computation to return a+-- stream of results.  The use of 'yieldItem' cannot be rolled back,+-- no subsequenct throwError,mzero,fail,lookAhead, or use of callCC+-- will lose any yielded value.  To report yielded value at an+-- intermediate point, without asking for more input, use+-- 'flushItems'.  To get a count of items yielded and not flushed, use+-- 'pendingItems', which returns 0 immediately after 'flushItems'.+--+-- 'suspendUntilComplete' repeatedly uses a partial continuation to+-- ask for more input until Nothing is passed and then it proceeds+-- with parsing.+--+-- The 'getAvailable' command returns the lazy byte string the parser+-- has remaining before calling 'suspend'.  The 'putAvailable'+-- replaces this input and is a bit fancy: it also replaces the input+-- at the current offset for all the potential catchError/mplus+-- handlers.  This change is _not_ reverted by fail/throwError/mzero.+--+-- The three 'lookAhead' and 'lookAheadM' and 'lookAheadE' functions are+-- the same as the ones in binary's Data.Binary.Get.+--+-- 'getCC' and 'getCC1' are handy wrapper of 'callCC' that I have included here.+--+module Text.ProtocolBuffers.MyGetW+    (Get,runGet,Result(..)+    ,CompGet,runCompGet,CompResult(..)+     -- main primitives to parse items+    ,ensureBytes,getStorable,getLazyByteString,getByteString,suspendUntilComplete+     -- observe or replace the remaining BinaryParser input+    ,getAvailable,putAvailable+     -- return a Sequence of items.+    ,yieldItem,flushItems,pendingItems+     -- lookAhead capabilities+    ,lookAhead,lookAheadM,lookAheadE+     -- too good not to include with this MonadCont+    ,getCC,getCC1+     -- below is for implementation of BinaryParser (for Int64 and Lazy bytestrings)+    ,bytesRead,isEmpty,remaining+    ,skip,spanOf+    ,getWord8,getWordhost+    ,getWord16be,getWord32be,getWord64be+    ,getWord16le,getWord32le,getWord64le+    ,getWord16host,getWord32host,getWord64host+    ) where++-- import Debug.Trace(trace)++-- The InternalGet monad is an instance of binary-strict's BinaryParser:+import qualified Data.Binary.Strict.Class as P(BinaryParser(..))+-- The InternalGet monad is an instance of all of these...+import Control.Applicative(Alternative(..),Applicative(..))+import Control.Monad.Cont.Class(MonadCont(callCC))+import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg,noMsg))+import Control.Monad.Reader.Class(MonadReader(ask,local))+import Control.Monad.Writer.Class(MonadWriter(tell,listen,pass))+import Control.Monad.State.Class(MonadState(get,put))+import Control.Monad.Trans(MonadTrans(lift),MonadIO(liftIO))+import Control.Monad(MonadPlus(mzero,mplus))++import Data.Char++-- implementation imports+import Control.Monad(liftM,ap)                       -- instead of Functor.fmap; ap for Applicative+import Control.Monad(replicateM)                      -- XXX testing+import Control.Monad((>=>)) -- XX testing+import Control.Monad.Identity(Identity,runIdentity)  -- Get is a transformed Identity monad+import Data.Bits(Bits((.|.)))+import qualified Data.ByteString as S(concat,length,null,splitAt)+import qualified Data.ByteString as S(pack,unpack) -- XXX testing+import qualified Data.ByteString.Internal as S(ByteString,toForeignPtr,inlinePerformIO)+import qualified Data.ByteString.Unsafe as S(unsafeIndex)+import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,empty)+import qualified Data.ByteString.Lazy as L(pack,unpack) -- XXX testing+import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk)+import qualified Data.Foldable as F(foldr1)          -- used with Seq+import Data.Function(fix)                            -- used in clever definition of getCC+import Data.Int(Int64)                               -- index type for L.ByteString+import Data.Monoid(Monoid(mempty,mappend))           -- Writer has a Monoid contraint+import Data.Sequence(Seq,length,null,(|>))           -- used for future queue in handler state+import Data.Word(Word,Word8,Word16,Word32,Word64)+import Foreign.ForeignPtr(withForeignPtr)+import Foreign.Ptr(castPtr,plusPtr)+import Foreign.Storable(Storable(peek,sizeOf))+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base(Int(..),uncheckedShiftL#)+import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#)+#endif++default()++-- Simple external return type+data Result y a = Failed !(Seq y) {-# UNPACK #-} !Int64 String+                | Finished !(Seq y) {-# UNPACK #-} !L.ByteString {-# UNPACK #-} !Int64 a+                | Partial !(Seq y) !(Either ( Result y a  )  -- use laziness+                                            ( Maybe L.ByteString -> Result y a ))++-- Complex external return type+data CompResult y w user m a =+    CFailed !(Seq y) {-# UNPACK #-} !Int64 String+  | CFinished  !(Seq y) {-# UNPACK #-} !L.ByteString {-# UNPACK #-} !Int64 w user a+  | CPartial !(Seq y) !(Either ( m (CompResult y w user m a) ) -- use laziness+                                   ( Maybe L.ByteString -> m (CompResult y w user m a) ))++-- Internal type, converted to an external type before returning to caller.+data IResult y e w user m a =+    IFailed !(Seq y) {-# UNPACK #-} !Int64 e+  | IFinished !(Seq y) w {-# UNPACK #-} !(S user) a+  | IPartial !(Seq y) !(Either ( m (IResult y e w user m a) )+                               ( Maybe L.ByteString -> m (IResult y e w user m a) ))++-- Internal state type, not exposed to the user.+data S user = S { top :: {-# UNPACK #-} !S.ByteString+                , current :: {-# UNPACK #-} !L.ByteString+                , consumed :: {-# UNPACK #-} !Int64+                , user_field :: user+                }+  deriving Show++-- easier names+type SuccessContinuation b y e r w user m a =+  (a -> r -> w -> (S user) -> TopFrame b y e w user m -> m (IResult y e w user m b))++type ErrorHandler b y e w user m =+  ( (S user) -> TopFrame b y e w user m -> e -> m (IResult y e w user m b))++-- Private Internal error handling stack type+-- This must NOT be exposed by this module+data FrameStack b y e w user m =+    ErrorFrame { top_error_handler :: ErrorHandler b y e w user m -- top level handler+               , input_continues :: {-# UNPACK #-} !Bool -- True at start, False if Nothing passed to suspend continuation+               }+  | HandlerFrame { frame_id :: {-# UNPACK #-} !Word64 -- needed for MonadCont(callCC)+                 , error_handler :: !(Maybe (ErrorHandler b y e w user m))  -- encapsulated handler+                 , stored_state :: {-# UNPACK #-} !(S user)  -- stored state to pass to handler+                 , future_input :: {-# UNPACK #-} !(Seq L.ByteString)  -- additiona input to hass to handler+                 , older_frame :: !(FrameStack b y e w user m)  -- older handlers+                 }++-- This is a version of FrameStack that does not retain the state, and+-- is used by MonadCont.+data CallCCStack b y e w user m =+    CC_ErrorFrame+  | CC_HandlerFrame {-# UNPACK #-} !Word64+                    !(Maybe (ErrorHandler b y e w user m))+                    !(CallCCStack b y e w user m)  -- older handlers++-- TopFrame is used as storage for a unique counter (Word64) that is+-- used to label the HanderFrames in increasing order as they are+-- created.  This is only needed so that callCC can distinguish the age+-- of items in the FrameStack as being present at the original use of +-- callCC or being newer.+--+-- TopFrame's unique value is used and incremented when a new+-- HandlerFrame is allocated by catchError.  It will start at 1.+--+-- The (Seq y) of of yielded values in the TopFrame are the yielded+-- results which are waiting to be put in the next IReturn value.+data TopFrame b y e w user m  = TopFrame Word64 (Seq y) (FrameStack b y e w user m)+  deriving Show++-- Internal monad type+newtype InternalGet b y e r w user m a = InternalGet {+      unInternalGet :: SuccessContinuation b y e r w user m a+              -> r                          -- reader+              -> w                          -- log so far+              -> (S user)                   -- state+              -> TopFrame b y e w user m    -- error handler stack+              -> m (IResult y e w user m b) -- operation+      }++-- Complex external monad type, but errors are String+type CompGet b y r w user m = InternalGet b y String r w user m++-- Simple external monad type+type Get b y = CompGet b y () () () Identity++-- These implement the checkponting needed to store and revive the+-- state for lookAhead.  They are fragile because the setCheckpoint+-- must preceed either useCheckpoint or clearCheckpoint but not both.+-- The FutureFrame must be the most recent handler, so the commands+-- must be in the same scope depth.  Because of these constraints, the reader+-- value 'r' does not need to be stored and can be taken from the InternalGet+-- parameter.+--+-- IMPORTANT: Any FutureFrame at the top level(s) is discarded by throwError.+setCheckpoint,useCheckpoint,clearCheckpoint :: InternalGet b y e r w user m ()+setCheckpoint = InternalGet $ \ sc r w s (TopFrame u ys pc) ->+  sc () r w s (TopFrame (succ u) ys (HandlerFrame u Nothing s mempty pc))+clearCheckpoint = InternalGet $ \ sc r w s (TopFrame u ys (HandlerFrame _u catcher _s _future pc)) ->+  case catcher of+    Just {} -> error "Impossible: Bad use of clearCheckpoint, error_handler was Just instead of Nothing"+    Nothing -> sc () r w s (TopFrame u ys pc)++-- | 'lookAhead' runs the @todo@ action and then rewinds only the+-- BinaryParser state.  Any new input from 'suspend' or changes from+-- 'putAvailable' are kept.  Changes to the user state (MonadState)+-- are kept.  The MonadWriter output is retained.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAhead :: (Monad m, Error e)+          => InternalGet b y e r w user m a+          -> InternalGet b y e r w user m a+lookAhead todo = do+  setCheckpoint+  a <- todo+  useCheckpoint+  return a++-- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the +-- BinaryParser state is rewound (as in 'lookAhead').  If the action return 'Just' then+-- the BinaryParser is not rewound, and lookAheadM acts as an identity.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAheadM :: (Monad m, Error e)+           => InternalGet b y e r w user m (Maybe a)+           -> InternalGet b y e r w user m (Maybe a)+lookAheadM todo = do+  setCheckpoint+  a <- todo+  maybe useCheckpoint (\_ -> clearCheckpoint) a+  return a++-- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the +-- BinaryParser state is rewound (as in 'lookAhead').  If the action return 'Right' then+-- the BinaryParser is not rewound, and lookAheadE acts as an identity.+--+-- If an error is thrown then the entire monad state is reset to last+-- catchError as usual.+lookAheadE :: (Monad m, Error e)+           => InternalGet b y e r w user m (Either a b)+           -> InternalGet b y e r w user m (Either a b)+lookAheadE todo = do+  setCheckpoint+  a <- todo+  either (\_ -> useCheckpoint) (\_ -> clearCheckpoint) a+  return a++-- 'collect' is used by 'putCheckpoint' and 'throwError'+collect :: (S user) -> Seq L.ByteString -> (S user)+collect sIn future | Data.Sequence.null future = sIn+                   | otherwise = sIn { current = mappend (current sIn) (F.foldr1 mappend future) }++instance (Show a,Show y) => Show (Result y a) where+  showsPrec _ (Failed ys n msg) = scon "Failed" $ sparen ys . sshows n . sshows msg+  showsPrec _ (Finished ys bs n a) = scon "Finished" $ sparen ys . sparen bs . sshows n . sparen a+  showsPrec _ (Partial ys c) = scon "Partial" $ sparen ys . showsEither c++instance (Show w, Show user, Show a,Show y) => Show (CompResult y w user m a) where+  showsPrec _ (CFailed ys n msg) = scon "CFailed" $ sparen ys . sshows n . sshows msg+  showsPrec _ (CFinished ys bs n w user a) = scon "CFinished" $ sparen ys . sparen bs . sshows n . sparen w . sparen user . sparen a+  showsPrec _ (CPartial ys c) = scon "CPartial" $ sparen ys . showsEither c++instance (Show user, Show a, Show w,Show y,Show e) => Show (IResult y e w user m a) where+  showsPrec _ (IFailed ys n msg) = scon "IFailed" $ sparen ys . sshows n . sshows msg+  showsPrec _ (IFinished ys w s a) = scon "CFinished" $ sparen ys . sparen w . sparen s . sparen a+  showsPrec _ (IPartial ys c) = scon "CPartial" $ sparen ys . showsEither c++instance (Show s,Show y) => Show (FrameStack b y e w s m) where+  showsPrec _ (ErrorFrame _ p) = scon "ErrorFrame <>" $ sshows p+  showsPrec _ (HandlerFrame u _ s future pc) = scon "(HandlerFrame " $ sshows u . (" <>"++) . sparen s . sparen future . ('\n':) . indent . shows pc++scon :: String -> ShowS -> ShowS+scon c s = ("("++) . (c++) . (' ':) . s . (')':)+sparen :: (Show x) => x -> ShowS+sparen s = (" ("++) . shows s . (')':)+sshows :: (Show x) => x -> ShowS+sshows s = (' ':) . shows s +indent :: String -> String+indent = unlines . map ("  "++) . lines+showsEither :: Either a b -> ShowS+showsEither (Left _) = shows " (Left <>)"+showsEither (Right _) = shows " (Right <>)"++chunk :: S user -> L.ByteString+chunk s = L.chunk (top s) (current s)++-- | 'runCompGet' is the complex executor+runCompGet :: (Monad m,Monoid w)+            => CompGet a y r w user m a+            -> r -> user -> L.ByteString+            -> m (CompResult y w user m a)+runCompGet g rIn userIn bsIn = liftM convert (unInternalGet g scIn rIn mempty sIn (TopFrame 1 mempty (ErrorFrame ecIn True)))+  where sIn = case bsIn of L.Empty -> S mempty mempty 0 userIn+                           L.Chunk ss bs -> S ss bs 0 userIn+        scIn a _r w sOut (TopFrame _u ys _pc) = return (IFinished ys w sOut a)+        ecIn sOut (TopFrame _u ys _pc) msg = return (IFailed ys (consumed sOut) msg)++        convert :: (Monad m) => IResult y String w user m a -> CompResult y w user m a+        convert (IFailed ys n msg) = CFailed ys n msg+        convert (IFinished ys w (S ss bs n user) a) = CFinished ys (L.chunk ss bs) n w user a+        convert (IPartial ys f) = CPartial ys (case f of+                                                 Left f' -> Left $ liftM convert f'+                                                 Right f' -> Right $ \bs -> liftM convert (f' bs) )++-- | 'runGet' is the simple executor+runGet :: Get a y a -> L.ByteString -> Result y a+runGet g bsIn = convert (runIdentity (unInternalGet g scIn () mempty sIn (TopFrame 1 mempty (ErrorFrame ecIn True))))+  where sIn = case bsIn of L.Empty -> S mempty mempty 0 ()+                           L.Chunk ss bs -> S ss bs 0 ()+        scIn a _r w sOut (TopFrame _u ys _pc) = return (IFinished ys w sOut a)+        ecIn sOut (TopFrame _u ys _pc) msg = return (IFailed ys (consumed sOut) msg)++        convert :: IResult y String () () Identity a -> Result y a+        convert (IFailed ys n msg) = Failed ys n msg+        convert (IFinished ys _ (S ss bs n _) a) = Finished ys (L.chunk ss bs) n a+        convert (IPartial ys f) = Partial ys (case f of+                                                Left f' -> Left $ convert (runIdentity f')+                                                Right f' -> Right $ \bs -> convert (runIdentity (f' bs)))++-- | Get the input currently available to the parser.  If this is+-- preceded by 'suspendUntilComplete' then this will definitely by the+-- complete length.+getAvailable :: InternalGet b y e r w user m L.ByteString+getAvailable = InternalGet $ \ sc r w s pc -> sc (chunk s) r w s pc++-- | 'putAvailable' replaces the bytestream past the current # of read+-- bytes.  This will also affect pending MonadError handler and+-- MonadPlus branches.  I think all pending branches have to have+-- fewer bytesRead than the current one.  If this is wrong then an+-- error will be thrown.+--+-- Currently this does not change the flag which indicates whether+-- Nothing has ever been passed to a continuation to indicate the hard+-- end of input.  This poperty is subject to change.+--+-- WARNING : 'putAvailable' is still untested.+putAvailable :: L.ByteString -> InternalGet b y e r w user m ()+putAvailable bsNew = InternalGet $ \ sc r w (S _ss _bs n user) (TopFrame uIn ys pc) ->+  let s' = case bsNew of+             L.Empty -> S mempty mempty n user+             L.Chunk ss' bs' -> S ss' bs' n user+      rebuild (HandlerFrame u catcher sOld@(S _ss1 _bs1 n1 user1) future pc') =+               HandlerFrame u catcher sNew mempty (rebuild pc')+        where balance = n - n1+              whole | balance < 0 = error "Impossible? Cannot rebuild HandlerFrame in MyGetW.putAvailable: balance is negative!"+                    | otherwise = L.take balance . chunk $ collect sOld future+              sNew | balance /= L.length whole = error "Impossible? MyGetW.putAvailable.rebuild.sNew HandlerFrame assertion failed."+                   | otherwise = case mappend whole bsNew of+                                   L.Empty -> S mempty mempty n1 user1+                                   L.Chunk ss2 bs2 -> S ss2 bs2 n1 user1+      rebuild x@(ErrorFrame {}) = x+  in sc () r w s' (TopFrame uIn ys (rebuild pc))++-- Internal access to full internal state, as helepr functions+getFull :: InternalGet b y e r w user m (S user)+getFull = InternalGet $ \ sc r w s pc -> sc s r w s pc+putFull :: (S user) -> InternalGet b y e r w user m ()+putFull s = InternalGet $ \ sc r w _ pc -> sc () r w s pc++-- | Keep calling 'suspend' until Nothing is passed to the 'Partial'+-- continuation.  This ensures all the data has been loaded into the+-- state of the parser.+suspendUntilComplete :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m ()+suspendUntilComplete = do+  continue <- suspend+  if continue then suspendUntilComplete+    else return ()++-- | Call suspend and throw and error with the provided @msg@ if+-- Nothing has been passed to the 'Partial' continuation.  Otherwise+-- return ().+suspendMsg :: ({-Show user,-} Error e, Monad m) => e -> InternalGet b y e r w user m ()+suspendMsg msg = do continue <- suspend+                    if continue then return ()+                      else throwError msg+{-# INLINE suspendMsg #-}++-- | check that there are at least @n@ bytes available in the input.+-- This will suspend if there is to little data.+ensureBytes :: ({-Show user,-} Error e, Monad m) => Int64 -> InternalGet b y e r w user m ()+ensureBytes n = do+  (S ss bs _offset _user) <- getFull+  if n < fromIntegral (S.length ss)+    then return ()+    else do if n == L.length (L.take n (L.chunk ss bs))+              then return ()+              else suspendMsg (strMsg "ensureBytes failed") >> ensureBytes n+{-# INLINE ensureBytes #-}++-- | Pull @n@ bytes from the unput, as a lazy ByteString.  This will+-- suspend if there is too little data.  +getLazyByteString :: ({-Show user,-} Error e, Monad m) => Int64 -> InternalGet b y e r w user m L.ByteString+getLazyByteString n = do+  (S ss bs offset user) <- getFull+  case splitAtOrDie n (L.chunk ss bs) of+    Just (consume,rest) -> do case rest of+                                L.Empty -> putFull (S mempty mempty (offset + n) user)+                                L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n) user)+                              return consume+    Nothing -> suspendMsg (strMsg "getLazyByteString failed") >> getLazyByteString n+{-# INLINE getLazyByteString #-} -- important++-- | 'suspend' is supposed to allow the execution of the monad to be+-- halted, awaiting more input.  The computation is supposed to+-- continue normally if this returns True, and is supposed to halt+-- without calling suspend again if this returns False.  All future+-- calls to suspend will return False automatically and no nothing+-- else.+--+-- These semantics are too specialized to let this escape this module.+class MonadSuspend y m | m -> y where+  suspend :: m Bool+  yieldItem :: y -> m ()+  flushItems :: m ()+  pendingItems :: m Int++-- The instance here is fairly specific to the stack manipluation done+-- by 'addFuture' to ('S' user) and to the packaging of the resumption+-- function in 'IResult'('IPartial').+instance ({-Show user,-} Error e, Monad m) => MonadSuspend y (InternalGet b y e r w user m) where+  suspend = InternalGet $ \ sc r w sIn pcIn@(TopFrame u ys pcInside) ->+    if checkBool pcInside -- Has Nothing ever been given to a partial continuation?+      then let f Nothing = let pcOut = TopFrame u mempty (rememberFalse pcInside)+                           in sc False r w sIn pcOut+               f (Just bs') | L.null bs' = let pcOut = TopFrame u mempty pcInside+                                           in sc True r w sIn pcOut+                            | otherwise = let sOut = appendBS sIn bs'+                                              pcOut = TopFrame u mempty (addFuture bs' pcInside)+                                          in sc True r w sOut pcOut+           in return (IPartial ys (Right f))+      else sc False r w sIn pcIn  -- once Nothing has been given suspend is a no-op+   where appendBS s@(S {current=bs}) bs' = s { current=mappend bs bs' }+         -- addFuture puts the new data in 'future' where throwError's collect can find and use it+         addFuture _bs x@(ErrorFrame {}) = x+         addFuture bs x@(HandlerFrame {future_input=future, older_frame=pc}) =+           x { future_input=future |> bs, older_frame= addFuture bs pc }+         -- Once suspend is given Nothing, it remembers this and always returns False+         checkBool (HandlerFrame {older_frame=pc}) = checkBool pc+         checkBool (ErrorFrame {input_continues=b}) = b+         rememberFalse x@(ErrorFrame {}) = x { input_continues=False }+         rememberFalse x@(HandlerFrame {older_frame=pc}) = x { older_frame=rememberFalse pc }++  yieldItem y = InternalGet $ \sc r w s (TopFrame u ys pc) ->+                  let ys' = ys |> y+                  in sc () r w s (TopFrame u ys' pc)++  -- This does nothing when there are no items pending, otherwise it+  -- returns IPartial (Seq y) (Left ...)+  flushItems = InternalGet $ \sc r w s tf@(TopFrame u ys pc) ->+                 if Data.Sequence.null ys then sc () r w s tf+                   else let lazy'rest = sc () r w s (TopFrame u mempty pc)+                        in return (IPartial ys (Left lazy'rest))++  pendingItems = InternalGet $ \sc r w s pc@(TopFrame _ ys _) -> sc (Data.Sequence.length ys) r w s pc++          +-- Useful wrappers around callCC++getCC :: (MonadCont m) => m (m a)+getCC = callCC (return . fix)+{-# INLINE getCC #-}++getCC1 :: (MonadCont m) => a -> m ( a -> m b ,  a  )+getCC1 x = callCC $ \k -> let jump a = k (jump,a) in return (jump,x)+{-# INLINE getCC1 #-}++-- A unique sort of command...++-- | 'discardInnerHandler' causes the most recent catchError to be+-- discarded, i.e. this reduces the stack of error handlers by removing+-- the top one.  These are the same handlers which Alternative((<|>)) and+-- MonadPlus(mplus) use.  This is useful to commit to the current branch and let+-- the garbage collector release the suspended handler and its hold on+-- the earlier input.+discardInnerHandler :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m ()+discardInnerHandler = InternalGet $ \ sc r w s (TopFrame u ys pcIn) ->+  let pcOut = case pcIn of ErrorFrame {} -> pcIn+                           HandlerFrame _ _ _ _ pc' -> pc'+  in sc () r w s (TopFrame u ys pcOut)+{-# INLINE discardInnerHandler #-}++-- | 'discardAllHandlers' causes all catchError handler to be+-- discarded, i.e. this reduces the stack of error handlers to the top+-- level handler.  These are the same handlers which Alternative((<|>))+-- and MonadPlus(mplus) use.  This is useful to commit to the current+-- branch and let the garbage collector release the suspended handlers+-- and their hold on the earlier input.+discardAllHandlers :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m ()+discardAllHandlers = InternalGet $ \ sc r w s (TopFrame u ys pcIn) ->+  let base pc@(ErrorFrame {}) = pc+      base (HandlerFrame _ _ _ _ pc) = base pc+  in sc () r w s (TopFrame u ys (base pcIn))+{-# INLINE discardAllHandlers #-}++-- The BinaryParser instance:++-- INTERNALS :+-- the getWord*,getPtr,getStorable functions call getByteString+-- getByteString works with the first strict bytestring if the request fits+--   otherwise it call getLazyByteString and allocates a new strict bytestring for the result+-- getLazyByteString calls splitAtOrDie and+--   on Nothing it suspends and if that returns True then it tries again else throwError+--   on Just it returns the desired length lazy bytestring result and advances the parser++-- | Discard the next @m@ bytes+skip :: ({-Show user,-} Error e, Monad m) => Int64 -> InternalGet b y e r w user m ()+skip m | m <=0 = return ()+       | otherwise = do+  ensureBytes m+  (S ss bs n user) <- getFull+  case L.drop m (L.chunk ss bs) of+    L.Empty -> putFull (S mempty mempty (n+m) user)+    L.Chunk ss' bs' -> putFull (S ss' bs' (n+m) user)++-- | Return the number of 'bytesRead' so far.  Initially 0, never negative.+bytesRead :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Int64+bytesRead = fmap consumed getFull++-- | 'remaining' returns the number of bytes available before the+-- current input runs out and 'suspend' might be called (this is the+-- length of the lazy bytestring returned by 'getAvailable').  If this+-- is preceded by 'suspendUntilComplete' then this will definitely by+-- the complete length.+remaining :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Int64+remaining = do (S ss bs _ _) <- getFull+               return $ fromIntegral (S.length ss) + (L.length bs)++-- | Return True if the number of bytes 'remaining' is 0.  Any futher+-- attempts to read an empty parser will cal 'suspend'.+isEmpty :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Bool+isEmpty = do (S ss bs _ _) <- getFull+             return $ (S.null ss) && (L.null bs)++spanOf :: ({-Show user,-} Error e, Monad m) => (Word8 -> Bool) ->  InternalGet b y e r w user m (L.ByteString)+spanOf f = do let loop = do (S ss bs n user) <- getFull+                            let (pre,post) = L.span f (L.chunk ss bs)+                            case post of+                              L.Empty -> putFull (S mempty mempty (n + L.length pre) user)+                              L.Chunk ss' bs' -> putFull (S ss' bs' (n + L.length pre) user)+                            if L.null post+                              then fmap ((L.toChunks pre)++) $ do+                                     continue <- suspend+                                     if continue then loop+                                       else return (L.toChunks pre)+                              else return (L.toChunks pre)+              fmap L.fromChunks loop+{-# INLINE spanOf #-}++-- | Pull @n@ bytes from the input, as a strict ByteString.  This will+-- suspend if there is too little data.  If the result spans multiple+-- lazy chunks then the result occupies a freshly allocated strict+-- bytestring, otherwise it fits in a single chunk and refers to the+-- same immutable memory block as the whole chunk.+getByteString :: ({-Show user,-} Error e, Monad m) => Int -> InternalGet b y e r w user m S.ByteString+getByteString nIn = do+  (S ss bs n user) <- getFull+  if nIn < S.length ss+    then do let (pre,post) = S.splitAt nIn ss+            putFull (S post bs (n+fromIntegral nIn) user)+            return pre+    -- Expect nIn to be less than S.length ss the vast majority of times+    -- so do not worry about doing anything fancy here.+    else fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn))+{-# INLINE getByteString #-} -- important++getWordhost :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Word+getWordhost = getStorable+{-# INLINE getWordhost #-}++getWord8 :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Word8+getWord8 = getPtr 1+{-# INLINE getWord8 #-}++getWord16be,getWord16le,getWord16host :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Word16+getWord16be = do+    s <- getByteString 2+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w16` 8) .|.+              (fromIntegral (s `S.unsafeIndex` 1))+{-# INLINE getWord16be #-}+getWord16le = do+    s <- getByteString 2+    return $! (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord16le #-}+getWord16host = getStorable+{-# INLINE getWord16host #-}++getWord32be,getWord32le,getWord32host :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Word32+getWord32be = do+    s <- getByteString 4+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 3) )+{-# INLINE getWord32be #-}+getWord32le = do+    s <- getByteString 4+    return $! (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord32le #-}+getWord32host = getStorable+{-# INLINE getWord32host #-}+++getWord64be,getWord64le,getWord64host :: ({-Show user,-} Error e, Monad m) => InternalGet b y e r w user m Word64+getWord64be = do+    s <- getByteString 8+    return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 7) )+{-# INLINE getWord64be #-}+getWord64le = do+    s <- getByteString 8+    return $! (fromIntegral (s `S.unsafeIndex` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `S.unsafeIndex` 0) )+{-# INLINE getWord64le #-}+getWord64host = getStorable+{-# INLINE getWord64host #-}++instance ({-Show user,-} Error e, Monad m) => P.BinaryParser (InternalGet b y e r w user m) where+  skip = skip . fromIntegral+  bytesRead = fmap fromIntegral bytesRead+  remaining = fmap fromIntegral remaining+  isEmpty = isEmpty+  spanOf = fmap (S.concat . L.toChunks) . spanOf++  getByteString = getByteString+  getWordhost = getWordhost+  getWord8 = getWord8++  getWord16be = getWord16be+  getWord32be = getWord32be+  getWord64be = getWord64be++  getWord16le = getWord16le+  getWord32le = getWord32le+  getWord64le = getWord64le++  getWord16host = getWord16host+  getWord32host = getWord32host+  getWord64host = getWord64host++-- Below here are the class instances+    +instance ({-Show user,-} Error e, Monad m) => Functor (InternalGet b y e r w user m) where+  fmap f m = InternalGet (\sc -> unInternalGet m (sc . f))+  {-# INLINE fmap #-}++instance ({-Show user,-} Monad m,Error e) => Monad (InternalGet b y e r w user m) where+  return a = InternalGet (\sc -> sc a)+  {-# INLINE return #-}+  m >>= k  = InternalGet (\sc -> unInternalGet m (\a -> unInternalGet (k a) sc))+  {-# INLINE (>>=) #-}+  fail msg = throwError (strMsg msg)++instance MonadTrans (InternalGet b y e r w user) where+  lift m = InternalGet (\sc r w s pc -> m >>= \a -> sc a r w s pc)++instance ({-Show user,-} MonadIO m,Error e) => MonadIO (InternalGet b y e r w user m) where+  liftIO = lift . liftIO++getPC :: InternalGet b y e r w user m (TopFrame b y e w user m)+getPC = InternalGet $ \ sc r w s pc -> sc pc r w s pc++putPC :: TopFrame b y e w user m -> InternalGet b y e r w user m (TopFrame b y e w user m)+putPC pc = InternalGet $ \ sc r w s _pc -> sc pc r w s pc++--countPC :: ({-Show user,-} Monad m) => InternalGet b y e r w user m Int+countPC :: (Monad m,Error e) => InternalGet b y e r w user m Int+countPC = do+  let go (ErrorFrame {}) i = i+      go (HandlerFrame _ _ _ _ pc) i = go pc $! succ i+  (TopFrame _ _ pc) <- getPC+  return (go pc 0)++--instance ({-Show user,-} Monad m, Error e) => MonadCont (InternalGet b y e r w user m) where+instance (Show user, Error e) => MonadCont (InternalGet b y e r w user IO) where+  callCC receiver = InternalGet $ \scCaptured rCaptured wCaptured sIn pcIn@(TopFrame _u _ys pcCaptured) ->+    let -- cleanPC is a version of the stack that does not retain the user state or BinaryParser state+        cleanedPC = cleanPC pcCaptured+          where cleanPC (ErrorFrame {}) = CC_ErrorFrame+                cleanPC (HandlerFrame u f _ _ pc) = CC_HandlerFrame u f (cleanPC pc)+        -- kont is the continuation captured and passed to the receiver. It refers to cleanedPC+        -- and used this to 'rebuild' a new stack with the data & stack at the usage site.+        -- It also refers to rCaptured and wCaptured.+        kont a = InternalGet $ \_sc _r _w sDyn (TopFrame uDyn ysDyn pcDyn) -> seq cleanedPC $+          scCaptured a rCaptured wCaptured sDyn (TopFrame uDyn ysDyn (rebuild sDyn pcDyn cleanedPC))+  -- Error vs any+        rebuild _sNew new@(ErrorFrame {}) (CC_ErrorFrame) = new  -- adopt new version of shared dynamic root+        rebuild sNew (HandlerFrame _ _ _ _ pcNew) old@(CC_ErrorFrame) = rebuild sNew pcNew old+        rebuild sNew new@(ErrorFrame {}) (CC_HandlerFrame uOld catcherOld pcOld)+            = HandlerFrame uOld catcherOld sNew mempty (rebuild sNew new pcOld)+  -- Two Handlers or Futures+        rebuild sNew new@(HandlerFrame uNew _ _ _ pcNew) old@(CC_HandlerFrame uOld catcherOld pcOld) =+          case compare uNew uOld of+            GT -> rebuild sNew pcNew old    -- discard newer frame with larger uNew+            EQ -> new  -- adopt new version of shared dynamic root+            LT -> HandlerFrame uOld catcherOld sNew mempty (rebuild sNew new pcOld)+                  -- above updates and re-instantiates the old context, and proceeds deeper+    in unInternalGet (receiver kont) scCaptured rCaptured wCaptured sIn pcIn++instance ({-Show user,-} Monad m,Error e) => MonadError e (InternalGet b y e r w user m) where+  throwError msg = InternalGet $ \_sc _r _w s tf@(TopFrame u ys pcIn) ->+    let go (ErrorFrame ec _) = ec s tf msg+        go (HandlerFrame _ (Just catcher) s1 future pc1) = catcher (collect s1 future) (TopFrame u ys pc1) msg+        go (HandlerFrame _ Nothing _ _ pc1) = go pc1+    in go pcIn++  catchError mayFail handler = InternalGet $ \scCaptured rCaptured wCaptured s (TopFrame u ys pc) ->+    let pcWithHandler = let catcher s1 pc1 e1 = unInternalGet (handler e1) scCaptured rCaptured wCaptured s1 pc1+                        in TopFrame (succ u) ys (HandlerFrame u (Just catcher) s mempty pc)+        actionWithCleanup = mayFail >>= \a -> discardInnerHandler >> return a+    in unInternalGet actionWithCleanup scCaptured rCaptured wCaptured s pcWithHandler++instance ({-Show user,-} Monad m, Error e, Monoid w) => MonadWriter w (InternalGet b y e r w user m) where+  tell w'  = InternalGet (\sc r w -> sc () r (mappend w w'))+  listen m = InternalGet (\sc r w -> let sc' a r' w'= sc (a,w') r' (mappend w w')+                                     in unInternalGet m sc' r mempty)+  pass m   = InternalGet (\sc r w s pc -> let sc' (a,f) r' w' s' pc' = sc a r' (mappend w (f w')) s' pc'+                                          in unInternalGet m sc' r mempty s pc)++instance ({-Show user,-} Monad m, Error e) => MonadReader r (InternalGet b y e r w user m) where+  ask = InternalGet (\sc r -> sc r r)+  local f m = InternalGet (\sc r -> let sc' a _ = sc a r+                              in unInternalGet m sc' (f r))+              +instance ({-Show user,-} Monad m,Error e) => MonadState user (InternalGet b y e r w user m) where+  get   = InternalGet (\sc r w s -> sc (user_field s) r w s)+  put u = InternalGet (\sc r w s -> let s' = s {user_field=u}+                              in sc () r w s')++instance ({-Show user,-} Monad m, Error e) => MonadPlus (InternalGet b y e r w user m) where+  mzero = throwError noMsg+  mplus m1 m2 = catchError m1 (const m2)++instance ({-Show user,-} Monad m,Error e) => Applicative (InternalGet b y e r w user m) where+  pure = return+  (<*>) = ap++instance ({-Show user,-} Monad m,Error e) => Alternative (InternalGet b y e r w user m) where+  empty = mzero+  (<|>) = mplus++-- | I use splitAt without tolerating too few bytes, so write a Maybe version.+-- This is the only place I invoke L.Chunk as constructor instead of pattern matching.+-- I claim that the first argument cannot be empty.+splitAtOrDie :: Int64 -> L.ByteString -> Maybe (L.ByteString, L.ByteString)+splitAtOrDie i ps | i <= 0 = Just (L.Empty, ps)+splitAtOrDie _i L.Empty = Nothing+splitAtOrDie i (L.Chunk x xs) | i < len = let (pre,post) = S.splitAt (fromIntegral i) x+                                          in Just (L.Chunk pre L.Empty+                                                  ,L.Chunk post xs)+                              | otherwise = case splitAtOrDie (i-len) xs of+                                              Nothing -> Nothing+                                              Just (y1,y2) -> Just (L.Chunk x y1,y2)+  where len = fromIntegral (S.length x)+{-# INLINE splitAtOrDie #-}++-- getPtr copied from binary's Get.hs+------------------------------------------------------------------------+-- Primtives++-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString. So many indirections from the raw parser+-- state that my head hurts...++getPtr :: ({-Show user,-} Error e, Monad m,Storable a) => Int -> InternalGet b y e r w user m a+getPtr n = do+    (fp,o,_) <- fmap S.toForeignPtr (getByteString n)+    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getPtr #-}++getStorable :: forall b y e r w user m a. ({-Show user,-} Error e, Monad m,Storable a) => InternalGet b y e r w user m a+getStorable = do+    (fp,o,_) <- fmap S.toForeignPtr (getByteString (sizeOf (undefined :: a)))+    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getStorable #-}++-- Unchecked shifts copied from binary's Get.hs+------------------------------------------------------------------------+------------------------------------------------------------------------+-- Unchecked shifts++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++#if __GLASGOW_HASKELL__ <= 606+-- Exported by GHC.Word in GHC 6.8 and higher+foreign import ccall unsafe "stg_uncheckedShiftL64"+    uncheckedShiftL64#     :: Word64# -> Int# -> Word64#+#endif++#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif++{- TESTING -}++chomp :: CompGet b y () String () IO ()+chomp = getByteString 1 >>= \w -> let string = map (toEnum . fromEnum) (S.unpack w)+                                  in tell string >> pr ("chomp "++show (S.unpack w)++" <"++string++">")++feed x (CPartial _ q) = either id ($ (Just (L.pack [x]))) q+feed x y = return y++test g bs = runCompGet g () () (L.pack bs)++test10 :: IO (CompResult () String () IO [()])+test10 = test (mplus (pr "go" >> replicateM 5 chomp >> pr "die" >> mzero) (pr "reborn" >> replicateM 10 chomp)) [1] >>= feed 2 >>= feed 3 >>= feed 4 >>= feed 5 >>= feed 6 >>= feed 7 >>=feed 8 >>= feed 9 >>= feed 10++pr :: (Show a) => a -> CompGet b y () String () IO ()+pr = liftIO . Prelude.print++-- Ensure the stack fixing in getCC and catchError play well together:+testDepth :: IO (CompResult () String () IO S.ByteString)+testDepth = test depth [] >>= feed12 >>= feedNothing where+  p s = do countPC >>= \d -> bytesRead >>= \ b -> remaining >>= \r -> pr ("stack depth",d,"bytes read",b,"bytes remaining",r,s)+           pr =<< getPC +  depth = do+    p "begin"+    catchError (p "mayFail" >> return () >> mzero)+               (\_ -> p "handler")+    p "middle"+    (_,w) <- listen $ do+      chomp+      flip catchError (\_ -> p "handler before getCC1") $ do+        (jumpWith,i) <- getCC1 (0 :: Int)                  -- jump into first handler from nested scope+        pr ("after jump and with "++show i)+        p "after getCC1, inside 1 handler"+        flip catchError (\_ -> p "handler after getCC1" >> mzero) $ do+          p "after getCC1, inside 2 handlers, before chomp"+          chomp+          p "after getCC1, inside 2 handlers, after chomp"+          mplus (p "in mplus left" >> if i<3 then jumpWith (succ i) else mzero) -- jump from nested scope to outer scope+                (p "in mplus right" >> mzero)+    pr ("listen",w)+    p "another middle"+    j2 <- flip catchError (\_ -> p "last handler" >> return Nothing) $ do+            chomp+            p "before inner jump2"+            (jump2,j) <- getCC1 (0 :: Int)                -- jump2 to inside this scope from afterwards+            p ("after inner jump2 with "++ show j)+            chomp+            if odd j then throwError "Ouch"+              else return (Just jump2)+    chomp+    p "after catchError scope of jump2"+    chomp+    maybe (pr "Nothing") (\j2->pr "jump2" >> j2 1) j2     -- jump2 back into previously left scope++    p "end"+    a <- getByteString 6+    p "got 6, now suspendUntilComplete"+    suspendUntilComplete+    return a++feed12 :: CompResult y w user IO a -> IO (CompResult y w user IO a)+feed12 = foldr1 (>=>) . map feeds $ [ [2*i,2*i+1]  | i <- [24..45]]+  where feeds x (CPartial _ q) = print ("feed1",x)  >> either id ($ (Just (L.pack x))) q+        feeds x y = return y++feedNothing :: CompResult y w user IO a -> IO (CompResult y w user IO a)+feedNothing (CPartial _ f) = case f of+                               Left g -> g+                               Right f' -> f' Nothing+feedNothing x = return x++runWCI todo = runCompGet todo () () mempty++lpl :: (MonadWriter w m, Monoid w) => m (a,w->w) -> m ((a,w),w)+lpl todo = listen . pass $ do+  ((a,f),w1) <- listen todo+  return ((a,w1),f)++flipCase a | isUpper a = toLower a+           | otherwise = toUpper a++wci,wci2,wci3 ::  IO (CompResult () String () IO ())+wci = runWCI $ do+  tell "a"+  x <- listen (tell "b")+  pr ("listen",x)+  y <- lpl $ do+         tell "c"+         return ("pass",map flipCase)+  pr y+  tell "d"+  return ()++{-+("listen",((),"b"))+(("pass","c"),"C")+(CFinished (Empty) (0) ("abCd") (()) (()))+-}++wci2 = runWCI $ do+  tell "a"+  (jump,i) <- getCC1 (0 :: Int)+  pr ("I see ",i)+  if i < 3+    then do+      x <- listen (tell "b")+      pr ("listen",x)+      y <- lpl $ do+             tell "c"+             if even i then jump (succ i) else return ()+             return ("pass",map flipCase)+      pr y+      tell "d"+      jump (succ i)+    else tell "e"+  tell "f"+  return ()++{-+("I see ",0)+("listen",((),"b"))+("I see ",1)+("listen",((),"b"))+(("pass","c"),"C")+("I see ",2)+("listen",((),"b"))+("I see ",3)+(CFinished (Empty) (0) ("aef") (()) (()))+-}++-- Test jumping into and out of the 'lpl : listen . pass .listen scope:+wci3 = runWCI $ do+  tell "a0"+  (top,j) <- getCC1 (0 :: Int)+  pr ("top sees",j)+  x <- listen (tell ",b1")+  pr ("listen",x)+  (((msg,jump,i),w1),w2) <- lpl $ do+         tell ",c2"+         (jump,i) <- getCC1 j+         pr ("jump sees",i)+         tell ",e100"+         if even i then top (succ i) else return ()+         return (("pass",jump,i),map flipCase)+  pr ((msg,i),w1,w2)+  tell ",d3"+  if i < 3 then jump (succ i) else return ()+  tell ",f1024"+  return ()+ where tell s = Control.Monad.Writer.Class.tell s >> pr ("told "++s)+{-+Annotated run of wci3 shows WriterT w (ContT r IO) semantics:++"told a0"                 -- "a0" is part of final log+                            -- ### no final log entries from the next section+("top sees",0)+"told ,b1"+("listen",((),",b1"))+"told ,c2"+("jump sees",0)+"told ,e100"+                             -- the use of 'top' erases the b1 c2 e100 above+("top sees",1) +"told ,b1"+("listen",((),",b1"))+"told ,c2"+("jump sees",1)+"told ,e100"+(("pass",1),",c2,e100",",C2,E100")+"told ,d3"+                              -- the use of 'jump' erases the b1 C2 E100 d3+("jump sees",2)         +"told ,e100"+                              -- the use of 'top' erases the e100+                          -- ### final log entries from here down+("top sees",3)+"told ,b1"+("listen",((),",b1"))+"told ,c2"+("jump sees",3)+"told ,e100"+(("pass",3),",c2,e100",",C2,E100")+"told ,d3"+"told ,f1024"+(CFinished (Empty) (0) ("a0,b1,C2,E100,d3,f1024") (()) (()))+-}
+ Text/ProtocolBuffers/Option.hs view
@@ -0,0 +1,47 @@+module Text.ProtocolBuffers.Option(Option(..),OptionFlag(..),Optional,Require,NotRequired,Required,op'Last,op'Merge) where++import Data.Monoid(Monoid(..))++class OptionFlag a where+  isValid :: Option a b -> Bool++instance OptionFlag NotRequired where+  isValid _ = True+instance OptionFlag Required where+  isValid Absent = False+  isValid _ = True++data NotRequired+data Required++type Optional b = Option NotRequired b+type Require b = Option Required b++data Option a b where +  Absent :: OptionFlag a => Option a b+  Present :: OptionFlag a => b -> Option a b++op'Last :: Option a b -> Option a b -> Option a b+op'Last Absent y = y+op'Last x Absent = x+op'Last x y = y++op'Merge :: (Monoid b) => Option a b -> Option a b -> Option a b+op'Merge Absent y = y+op'Merge x Absent = x+op'Merge (Present x) (Present y) = Present (mappend x y)++instance (OptionFlag a,Show b) => Show (Option a b) where+  show Absent = "Absent"+  show (Present b) = "Present ("++show b++")"++instance (OptionFlag a,Eq b) => Eq (Option a b) where+  (==) Absent Absent = True+  (==) (Present x) (Present y) = (==) x y+  (==) _ _ = False++instance (OptionFlag a,Ord b) => Ord (Option a b) where+  compare Absent Absent = EQ+  compare Absent _ = LT+  compare _ Absent = GT+  compare (Present x) (Present y) = compare x y
− Text/ProtocolBuffers/ParseProto.hs 
@@ -1,194 +0,0 @@-module Text.ProtocolBuffers.ParseProto where---- see compiler/parser.cc in the google source code--import qualified Text.DescriptorProtos.DescriptorProto                as D(DescriptorProto)-import qualified Text.DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))-import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto(ExtensionRange)-import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto.ExtensionRange(ExtensionRange(..))-import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto) -import qualified Text.DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..)) -import qualified Text.DescriptorProtos.EnumOptions                    as D(EnumOptions)-import qualified Text.DescriptorProtos.EnumOptions                    as D.EnumOptions(EnumOptions(..))-import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D(EnumValueDescriptorProto)-import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))-import qualified Text.DescriptorProtos.EnumValueOptions               as D(EnumValueOptions) -import qualified Text.DescriptorProtos.EnumValueOptions               as D.EnumValueOptions(EnumValueOptions(..)) -import qualified Text.DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto) -import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..)) -import qualified Text.DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto(Label)-import qualified Text.DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto.Label(Label(..))-import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type)-import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto.Type(Type(..))-import qualified Text.DescriptorProtos.FieldOptions                   as D(FieldOptions)-import qualified Text.DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))-import qualified Text.DescriptorProtos.FieldOptions.CType             as D.FieldOptions(CType)-import qualified Text.DescriptorProtos.FieldOptions.CType             as D.FieldOptions.CType(CType(..))-import qualified Text.DescriptorProtos.FileOptions                    as D(FileOptions)-import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto) -import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..)) -import qualified Text.DescriptorProtos.FileOptions                    as D.FileOptions(FileOptions(..))-import qualified Text.DescriptorProtos.FileOptions.OptimizeMode       as D.FileOptions(OptimizeMode)-import qualified Text.DescriptorProtos.FileOptions.OptimizeMode       as D.FileOptions.OptimizeMode(OptimizeMode(..))-import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto)-import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..))-import qualified Text.DescriptorProtos.MessageOptions                 as D(MessageOptions)-import qualified Text.DescriptorProtos.MessageOptions                 as D.MessageOptions(MessageOptions(..))-import qualified Text.DescriptorProtos.MethodOptions                  as D(MethodOptions)-import qualified Text.DescriptorProtos.MethodOptions                  as D.MethodOptions(MethodOptions(..))-import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D(ServiceDescriptorProto) -import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D.ServiceDescriptorProto(ServiceDescriptorProto(..)) -import qualified Text.DescriptorProtos.ServiceOptions                 as D(ServiceOptions)-import qualified Text.DescriptorProtos.ServiceOptions                 as D.ServiceOptions(ServiceOptions(..))--import Text.ProtocolBuffers.Header-import Text.ProtocolBuffers.Instances--import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Language(emptyDef,LanguageDef(..))-import qualified Text.ParserCombinators.Parsec.Token as T (makeTokenParser,TokenParser(..))--import Data.List(intersperse)-import Data.Maybe(maybe)-import Data.Maybe(maybe)-import Data.Monoid-import System.IO(readFile)-import Data.ByteString.Char8(pack)--import qualified Data.Sequence as Seq----t1 = mappend (Just (D.FileOptions.OptimizeMode.SPEED)) (Just (D.FileOptions.OptimizeMode.CODE_SIZE))--p = T.makeTokenParser protoDef---- see google's io/tokenizer.{h,c}-protoDef = emptyDef {-             commentStart = []-           , commentEnd = []-           -- commentLine is really useful-           , commentLine = "//"-           , nestedComments = False-           -- This ident* agrees with comments in io/tokenizer.h-           , identStart = letter-           , identLetter = alphaNum <|> char '_'-           , opStart = pzero-           , opLetter = pzero-           -- The following reservedNames and reservedOpNames maybe ought to be [] and []-           , reservedNames = ["option","message"-                             ,"required","options","repeated"-                             ,"double","float"-                             ,"int32","int64"-                             ,"uint32","uint64"-                             ,"sint32","sint64"-                             ,"fixed32","fixed64"-                             ,"sfixed32","sfixed64"-                             ,"bool","string","bytes"-                             ]-           , reservedOpNames = ["="]-           , caseSensitive = True-  }--skip = T.whiteSpace p-sym = T.symbol p-semi = T.semi p-ident = T.identifier p <?> "Expecting identifier (letter then letter or number or _)"--type US = ()---- Parsing a proto file produces a stream of items-data TopLevel = P !ByteString-              | D !ByteString -              | M D.DescriptorProto-              | E D.EnumDescriptorProto-              | S D.ServiceDescriptorProto-              | F D.FieldDescriptorProto-              | O D.FileOptions-  deriving Show--unique :: String -> [b] -> (Maybe b,Maybe String)-unique e [] = (Nothing,Nothing)-unique e [b] = (Just b,Nothing)-unique e bs = (Just (last bs),Just e)--fileDescriptorProto :: CharParser US D.FileDescriptorProto-fileDescriptorProto = do-  skipTop ()-  val <- many (topLevel >>= skipTop)---   -- Alternative to enforce having only a single package directive---   let (opPackage,mayErr) = unique "Multiple package definitions found, only one expected."---                                 [ x | P x <- val ]---   maybe (return ()) fail mayErr-  return (defaultValue { -- D.FileDescriptorProto.package = opPackage-                         D.FileDescriptorProto.package      = mergeConcat [ Just x | P x <- val ]-                       , D.FileDescriptorProto.dependency   = Seq.fromList [ x | D x <- val ]-                       , D.FileDescriptorProto.message_type = Seq.fromList [ x | M x <- val ]-                       , D.FileDescriptorProto.enum_type    = Seq.fromList [ x | E x <- val ]-                       , D.FileDescriptorProto.service      = Seq.fromList [ x | S x <- val ]-                       , D.FileDescriptorProto.extension    = Seq.fromList [ x | F x <- val ]-                       , D.FileDescriptorProto.options      = mergeConcat [ Just x | O x <- val ]-                       } )--skipTop :: a -> CharParser US a-skipTop x = skip >> skipMany (semi >> skip) >> return x -- ignore empty declarations--topLevel :: CharParser US TopLevel-topLevel =  choice [ messageTop-                   , enumTop -                   , serviceTop-                   , extendTop-                   , importTop-                   , packageTop-                   , optionTop-                   ] <?> "Expected top-level statement (e.g. \"message\")."--messageTop = string "message" >> do-  skip-  name <- ident-  return (M (defaultValue { D.DescriptorProto.name = Just (pack name) }))- -enumTop = pzero-serviceTop = pzero-extendTop = pzero-importTop = pzero-packageTop = string "package" >> do-  skip-  parts <- sepBy1 ident (char '.') <?> "Expect package name (a dotted itentifier, e.g. beep.giggle.whee)"-  skip >> semi-  return (P (pack (foldr1 (\a b -> a ++ '.':b) parts)))---- Hard code optionTop  avoid only use of reflection in google's parser--- This can be make reflective after bootstrapping if this program is ever finished-optionTop = string "option" >> do-  skip-  optionName <- ident-  skip-  char '='-  skip-  opt <- optionByName optionName-  skip >> semi-  return (O opt)- where-   optionByName "java_package" = do-     bs <- parseString-     return (defaultValue { D.FileOptions.java_package = Just bs })-   optionByName "java_outer_classname" = do-     bs <- parseString-     return (defaultValue { D.FileOptions.java_outer_classname = Just bs })-   optionByName "java_multiple_files" = do-     bool <- parseBool-     return (defaultValue { D.FileOptions.java_multiple_files = Just bool })-   optionByName "optimize_for" = do-     mode <- parseOptimizeMode-     return (defaultValue { D.FileOptions.optimize_for = Just mode })--parseString = pzero-parseBool = pzero-parseOptimizeMode = pzero--test f = do-  proto <- readFile f-  print $ parse fileDescriptorProto f proto--testTmp = fmap (parse fileDescriptorProto f) (readFile f)-  where f = "/tmp/test"-
+ Text/ProtocolBuffers/Parser.hs view
@@ -0,0 +1,364 @@+module Text.ProtocolBuffers.Parser(pbParse,parseProto,filename1,filename2) where++import qualified Text.DescriptorProtos.DescriptorProto                as D(DescriptorProto)+import qualified Text.DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))+import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto)+import qualified Text.DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D(EnumValueDescriptorProto(EnumValueDescriptorProto))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto(FieldDescriptorProto))+import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type)+import           Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto.Type(Type(..))+import qualified Text.DescriptorProtos.FieldOptions                   as D(FieldOptions)+import qualified Text.DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))+import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto)+import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..))+import qualified Text.DescriptorProtos.FileOptions                    as D.FileOptions(FileOptions(..))+import qualified Text.DescriptorProtos.MessageOptions                 as D.MessageOptions(MessageOptions(..))+import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto(MethodDescriptorProto))+import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..))+import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D.ServiceDescriptorProto(ServiceDescriptorProto(..))++import Text.ProtocolBuffers.Lexer(Lexed(..),alexScanTokens,getLinePos)+import Text.ProtocolBuffers.Header(ByteString,Int32,Int64,Word32,Word64+                                  ,mergeEmpty,ReflectEnum(reflectEnumInfo),enumName)+import Text.ProtocolBuffers.Instances(parseLabel,parseType)+import Control.Monad(when,liftM3)+import qualified Data.ByteString.Lazy.Char8 as LC(unpack,pack,notElem,head,readFile)+import Data.Char(isUpper)+import Data.Ix(inRange)+import Data.Sequence((|>))+import Text.ParserCombinators.Parsec(GenParser,ParseError,runParser,sourceName+                                    ,getInput,setInput,getPosition,setPosition,getState,setState+                                    ,(<?>),(<|>),option,token,choice,between,eof,unexpected)+import Text.ParserCombinators.Parsec.Pos(newPos)++type P = GenParser Lexed++pbParse :: String -> IO (Either ParseError D.FileDescriptorProto)+pbParse filename = fmap (parseProto filename) (LC.readFile filename)++parseProto :: String -> ByteString -> Either ParseError D.FileDescriptorProto+parseProto filename file = do+  let lexed = alexScanTokens file+      ipos = case lexed of+               [] -> setPosition (newPos filename 0 0)+               (l:_) -> setPosition (newPos filename (getLinePos l) 0)+  runParser (ipos >> parser) (initState filename) filename lexed++filename1,filename2 :: String+filename1 = "/tmp/unittest.proto"+filename2 = "/tmp/descriptor.proto"++initState :: String -> D.FileDescriptorProto+initState filename = mergeEmpty {D.FileDescriptorProto.name=Just (LC.pack filename)}++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++true,false :: ByteString+true = LC.pack "true"+false = LC.pack "false"++-- Use 'token' via 'tok' to make all the parsers for the Lexed values+tok :: (Lexed -> Maybe a) -> P s a+tok f = token show (\lexed -> newPos "" (getLinePos lexed) 0) f++pChar :: Char -> P s ()+pChar c = tok (\l-> case l of L _ x -> if (x==c) then return () else Nothing+                              _ -> Nothing) <?> ("character "++show c)++eol :: P s ()+eol = pChar ';'++pName :: ByteString -> P s ByteString+pName name = tok (\l-> case l of L_Name _ x -> if (x==name) then return x else Nothing+                                 _ -> Nothing) <?> ("name "++show (LC.unpack name))++strLit :: P s ByteString+strLit = tok (\l-> case l of L_String _ x -> return x+                             _ -> Nothing) <?> "quoted bytes or string literal"++intLit :: (Num a) => P s a+intLit = tok (\l-> case l of L_Integer _ x -> return (fromInteger x)+                             _ -> Nothing) <?> "integer literal"++fieldInt :: (Num a) => P s a+fieldInt = tok (\l-> case l of L_Integer _ x | inRange validRange x && not (inRange reservedRange x) -> return (fromInteger x)+                               _ -> Nothing) <?> "field number (from 0 to 2^29-1 and not in 19000 to 19999)"+  where validRange = (0,(2^(29::Int))-1)+        reservedRange = (19000,19999)++enumInt :: (Num a) => P s a+enumInt = tok (\l-> case l of L_Integer _ x | inRange validRange x -> return (fromInteger x)+                              _ -> Nothing) <?> "enum value (from 0 to 2^31-1)"+  where validRange = (0,(2^(31::Int))-1)++doubleLit :: P s Double+doubleLit = tok (\l-> case l of L_Double _ x -> return x+                                L_Integer _ x -> return (fromInteger x)+                                _ -> Nothing) <?> "double (or integer) literal"++ident,ident1,ident_package :: P s ByteString+ident = tok (\l-> case l of L_Name _ x -> return x+                            _ -> Nothing) <?> "identifier (perhaps dotted)"++ident1 = tok (\l-> case l of L_Name _ x | LC.notElem '.' x -> return x+                             _ -> Nothing) <?> "identifier (not dotted)"++ident_package = tok (\l-> case l of L_Name _ x | LC.head x /= '.' -> return x+                                    _ -> Nothing) <?> "package name (no leading dot)"++boolLit :: P s Bool+boolLit = tok (\l-> case l of L_Name _ x | x == true -> return True+                                         | x == false -> return False+                              _ -> Nothing) <?> "boolean literal ('true' or 'false')"++enumLit :: forall s a. (Read a,ReflectEnum a) => P s a -- This is very polymorphic, and with a good error message+enumLit = do+  s <- fmap' LC.unpack ident1+  case mayRead reads s of+    Just x -> return x+    Nothing -> let self = enumName (reflectEnumInfo (undefined :: a))+               in unexpected $ "Enum value not recognized: "++show s++", wanted enum value of type "++show self++-- subParser changes the user state. It is a bit of a hack and is used+-- to define an interesting style of parsing below.+subParser :: GenParser t sSub a -> sSub -> GenParser t s sSub+subParser doSub inSub = do+  in1 <- getInput+  pos1 <- getPosition+  let out = runParser (setPosition pos1 >> doSub >> getStatus) inSub (sourceName pos1) in1+  case out of Left pe -> fail ("the error message from the nested subParser was:\n"++indent (show pe))+              Right (outSub,in2,pos2) -> setInput in2 >> setPosition pos2 >> return outSub+ where getStatus = liftM3 (,,) getState getInput getPosition+       indent = unlines . map (\s -> ' ':' ':s) . lines++{-# INLINE return' #-}+return' :: (Monad m) => a -> m a+return' a = return $! a++{-# INLINE fmap' #-}+fmap' :: (Monad m) => (a->b) -> m a -> m b+fmap' f m = m >>= \a -> seq a (return $! (f a))++type Update s = (s -> s) -> P s ()+update' :: Update s+update' f = getState >>= \s -> setState $! (f s)++parser :: P D.FileDescriptorProto D.FileDescriptorProto +parser = proto >> getState+  where proto = eof <|> (choice [ eol+                                , importFile+                                , package+                                , fileOption+                                , message upTopMsg+                                , enum upTopEnum+                                , extend upTopMsg upTopField+                                , service] >> proto)+        upTopMsg msg = update' (\s -> s {D.FileDescriptorProto.message_type=D.FileDescriptorProto.message_type s |> msg})+        upTopEnum e  = update' (\s -> s {D.FileDescriptorProto.enum_type=D.FileDescriptorProto.enum_type s |> e})+        upTopField f = update' (\s -> s {D.FileDescriptorProto.extension=D.FileDescriptorProto.extension s |> f})++importFile = pName (LC.pack "import") >> strLit >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.dependency=(D.FileDescriptorProto.dependency s) |> p})++package = pName (LC.pack "package") >> ident_package >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.package=Just p})++pOption :: P s String+pOption = pName (LC.pack "option") >> fmap LC.unpack ident1 >>= \optName -> pChar '=' >> return optName++fileOption = pOption >>= setOption >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.options=Just p})+  where+    setOption optName = do+      old <- fmap (maybe mergeEmpty id . D.FileDescriptorProto.options) getState+      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})+        s -> unexpected $ "option name "++s++message :: (D.DescriptorProto -> P s ()) -> P s ()+message up = pName (LC.pack "message") >> do+  self <- ident1+  up =<< subParser (pChar '{' >> subMessage) (mergeEmpty {D.DescriptorProto.name=Just self})++-- subMessage is also used to parse group declarations+subMessage = (pChar '}') <|> (choice [ eol +                                     , field upNestedMsg Nothing >>= upMsgField+                                     , message upNestedMsg+                                     , enum upNestedEnum+                                     , extensions+                                     , extend upNestedMsg upMsgField+                                     , messageOption] >> subMessage)+  where upNestedMsg msg = update' (\s -> s {D.DescriptorProto.nested_type=D.DescriptorProto.nested_type s |> msg})+        upNestedEnum e  = update' (\s -> s {D.DescriptorProto.enum_type=D.DescriptorProto.enum_type s |> e})+        upMsgField f    = update' (\s -> s {D.DescriptorProto.field=D.DescriptorProto.field s |> f})++messageOption = pOption >>= setOption >>= \p -> eol >> update' (\s -> s {D.DescriptorProto.options=Just p}) +  where+    setOption optName = do+      old <- fmap (maybe mergeEmpty id . D.DescriptorProto.options) getState+      case optName of+        "message_set_wire_format" -> boolLit >>= \p -> return' (old {D.MessageOptions.message_set_wire_format=Just p})+        s -> unexpected $ "option name "++s++extend :: (D.DescriptorProto -> P s ()) -> (D.FieldDescriptorProto -> P s ())+       -> P s ()+extend upGroup upField = pName (LC.pack "extend") >> do+  typeExtendee <- ident+  let first = (eol >> first) <|> ((field upGroup (Just typeExtendee) >>= upField) >> rest)+      rest = pChar '}' <|> ((eol <|> (field upGroup (Just typeExtendee) >>= upField)) >> rest)+  pChar '{' >> first+  +field :: (D.DescriptorProto -> P s ()) -> Maybe ByteString+      -> P s D.FieldDescriptorProto+field upGroup maybeExtendee = do +  sLabel <- choice . map (pName . LC.pack) $ ["optional","repeated","required"]+  theLabel <- maybe (fail ("not a valid Label :"++show sLabel)) return (parseLabel (LC.unpack sLabel))+  sType <- ident+  let (maybeTypeCode,maybeTypeName) = case parseType (LC.unpack sType) of+                                        Just t -> (Just t,Nothing)+                                        Nothing -> (Nothing, Just sType)+  name <- ident1+  number <- pChar '=' >> fieldInt+  (maybeOptions,maybeDefault) <-+    if maybeTypeCode == Just TYPE_GROUP+      then do when (not (isUpper (LC.head name)))+                   (fail $ "Group names must start with an upper case letter: "++show name)+              upGroup =<< subParser (pChar '{' >> subMessage) (mergeEmpty {D.DescriptorProto.name=Just name})+              return (Nothing,Nothing)+      else do hasBracket <- option False (pChar '[' >> return True)+              pair <- if not hasBracket then return (Nothing,Nothing)+                        else subParser (subBracketOptions maybeTypeCode) (Nothing,Nothing)+              eol+              return pair+  return $ D.FieldDescriptorProto+               { D.FieldDescriptorProto.name = Just name+               , D.FieldDescriptorProto.number = Just number+               , D.FieldDescriptorProto.label = Just theLabel+               , D.FieldDescriptorProto.type' = maybeTypeCode+               , D.FieldDescriptorProto.type_name = maybeTypeName+               , D.FieldDescriptorProto.extendee = maybeExtendee+               , D.FieldDescriptorProto.default_value = maybeDefault+               , D.FieldDescriptorProto.options = maybeOptions+               }++subBracketOptions :: Maybe Type+                  -> P (Maybe D.FieldOptions, Maybe ByteString) ()+subBracketOptions mt = (defaultConstant <|> fieldOptions) >> (pChar ']' <|> (pChar ',' >> subBracketOptions mt))+  where defaultConstant = do+          pName (LC.pack "default")+          x <- pChar '=' >> constant mt+          (a,_) <- getState+          setState $! (a,Just x)+        fieldOptions = do+          optName <- fmap LC.unpack ident1+          pChar '='+          (mOld,def) <- getState+          let old = maybe mergeEmpty id mOld+          case optName of+            "ctype" | (Just TYPE_STRING) == mt -> do+              enumLit >>= \p -> let new = old {D.FieldOptions.ctype=Just p}+                                in seq new $ setState $! (Just new,def)+            "experimental_map_key" | Nothing == mt -> do+              strLit >>= \p -> let new = old {D.FieldOptions.experimental_map_key=Just p}+                               in seq new $ setState $! (Just new,def)+            s -> unexpected $ "option name: "++s++-- This does a type and range safe parsing of the default value,+-- except for enum constants which cannot be checked (the definition+-- may not have been parsed yet).+--+-- Double and Float are checked to be not-Nan and not-Inf.  The+-- int-like types are checked to be within the corresponding range.+constant :: Maybe Type -> P s ByteString+constant Nothing = ident1 -- hopefully a matching enum+constant (Just t) =+  case t of+    TYPE_DOUBLE  -> do d <- doubleLit+                       when (isNaN d || isInfinite d)+                            (fail $ "Floating point literal "++show d++" is out of range for type "++show t)+                       return' (LC.pack . show $ d)+    TYPE_FLOAT   -> do d <- doubleLit+                       let fl :: Float+                           fl = read (show d)+                       when (isNaN fl || isInfinite fl || (d==0) /= (fl==0))+                            (fail $ "Floating point literal "++show d++" is out of range for type "++show t)+                       return' (LC.pack . show $ d)+    TYPE_BOOL    -> boolLit >>= \b -> return' $ if b then true else false+    TYPE_STRING  -> strLit+    TYPE_BYTES   -> strLit+    TYPE_GROUP   -> unexpected $ "cannot have a constant literal for type "++show t+    TYPE_MESSAGE -> unexpected $ "cannot have a constant literal for type "++show t+    TYPE_ENUM    -> ident1 -- IMPOSSIBLE : SHOULD HAVE HAD Maybe Type PARAMETER match Nothing+    TYPE_SFIXED32 -> f (undefined :: Int32)+    TYPE_SINT32   -> f (undefined :: Int32)+    TYPE_INT32    -> f (undefined :: Int32)+    TYPE_SFIXED64 -> f (undefined :: Int64)+    TYPE_SINT64   -> f (undefined :: Int64)+    TYPE_INT64    -> f (undefined :: Int64)+    TYPE_FIXED32  -> f (undefined :: Word32)+    TYPE_UINT32   -> f (undefined :: Word32)+    TYPE_FIXED64  -> f (undefined :: Word64)+    TYPE_UINT64   -> f (undefined :: Word64)+  where f :: (Bounded a,Integral a) => a -> P s ByteString+        f u = do let range = (toInteger (minBound `asTypeOf` u),toInteger (maxBound `asTypeOf` u))+                 i <- intLit+                 when (not (inRange range i))+                      (fail $ "default value "++show i++" is out of range for type "++show t)+                 return' (LC.pack . show $ i)++enum :: (D.EnumDescriptorProto -> P s ()) -> P s ()+enum up = pName (LC.pack "enum") >> do+  self <- ident1+  up =<< subParser (pChar '{' >> subEnum) (mergeEmpty {D.EnumDescriptorProto.name=Just self})++subEnum = (pChar '}') <|> ((eol <|> enumVal <|> (pOption >>= setOption)) >> subEnum)+  where setOption = fail "There are no options for enumerations (when this parser was written)"+        enumVal :: P D.EnumDescriptorProto ()+        enumVal = do+          name <- ident1+          number <- pChar '=' >> enumInt+          eol+          let v = D.EnumValueDescriptorProto+                       { D.EnumValueDescriptorProto.name = Just name+                       , D.EnumValueDescriptorProto.number = Just number+                       , D.EnumValueDescriptorProto.options = Nothing+                       }+          update' (\s -> s {D.EnumDescriptorProto.value=D.EnumDescriptorProto.value s |> v})++extensions = pName (LC.pack "extensions") >> do+  start <- fmap Just fieldInt+  pName (LC.pack "to")+  end <- (fmap Just fieldInt <|> fmap (const Nothing) (pName (LC.pack "max")))+  let e = D.ExtensionRange+            { D.ExtensionRange.start = start+            , D.ExtensionRange.end = end+            }+  update' (\s -> s {D.DescriptorProto.extension_range=D.DescriptorProto.extension_range s |> e})++service = pName (LC.pack "service") >> do+  name <- ident1+  f <- subParser (pChar '{' >> subRpc) (mergeEmpty {D.ServiceDescriptorProto.name=Just name})+  update' (\s -> s {D.FileDescriptorProto.service=D.FileDescriptorProto.service s |> f})+       + where subRpc = pChar '}' <|> ((eol <|> rpc <|> (pOption >>= setOption)) >> subRpc)+       rpc = pName (LC.pack "rpc") >> do+               name <- ident1+               input <- between (pChar '(') (pChar ')') ident1+               pName (LC.pack "returns")+               output <- between (pChar '(') (pChar ')') ident1+               eol+               let m = D.MethodDescriptorProto+                         { D.MethodDescriptorProto.name=Just name+                         , D.MethodDescriptorProto.input_type=Just input+                         , D.MethodDescriptorProto.output_type=Just output+                         , D.MethodDescriptorProto.options=Nothing+                         }+               update' (\s -> s {D.ServiceDescriptorProto.method=D.ServiceDescriptorProto.method s |> m})+       setOption = fail "There are no options for services (when this parser was written)"
+ Text/ProtocolBuffers/Reflections.hs view
@@ -0,0 +1,228 @@+-- To get the defaults working sanely, I need to encode at least some reflection information.+-- The to-be-bootstrapped descriptor.proto structures are not parsed enough for sane default usage.+-- So this is currently over-designed for the immediate need of DescriptorInfo -> number -> FieldInfo -> Maybe HsDefault.+-- These data structures and API are quite likely to be rewritten.+--+-- A strong feature of this is that it does not contain any structures defined by descriptor.proto!+-- This prevents me hitting any circular dependencies.+--+-- +module Text.ProtocolBuffers.Reflections(ProtoName(..),DescriptorInfo(..),FieldInfo(..)+                                       ,HsDefault(..),EnumInfo(..),EnumInfoApp+                                       ,ReflectDescriptor(..),ReflectEnum(..),GetMessageInfo(..)+                                       ,parseDefDouble,parseDefFloat+                                       ,parseDefBool,parseDefInteger+                                       ,parseDefString,parseDefBytes+                                       ,cEncode,cDecode+                                       ) where++import Text.ProtocolBuffers.Basic++import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Data.ByteString.Lazy as BS (null,pack,unpack)+import qualified Data.ByteString.Lazy.Char8 as BSC(pack,unpack)+import Numeric(readHex,readOct,readDec,showOct)+import Data.Char(ord,chr,isHexDigit,isOctDigit,toLower)+import Data.List(sort,unfoldr)+import qualified Data.Foldable as F(toList)+import Data.Bits(Bits((.|.),shiftL))+import Data.Word(Word8)+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Generics(Data)+import Data.Typeable(Typeable)+import Test.QuickCheck(quickCheck)+import Codec.Binary.UTF8.String(encode)++data ProtoName = ProtoName { haskellPrefix :: String  -- Haskell specific prefix to module hierarchy (e.g. Text)+                           , parentModule :: String   -- Proto specified namespace (like java)+                           , baseName :: String       -- unqualfied name of this thing+                           }+  deriving (Show,Read,Eq,Ord,Data,Typeable)++data DescriptorInfo = DescriptorInfo { descName :: ProtoName+                                     , fields :: Seq FieldInfo }+  deriving (Show,Read,Eq,Ord,Data,Typeable)++data GetMessageInfo = GetMessageInfo { requiredTags :: Set WireTag+                                     , allowedTags :: Set WireTag+                                     }+  deriving (Show,Read,Eq,Ord,Data,Typeable)++data FieldInfo = FieldInfo { fieldName :: String+                           , fieldNumber :: FieldId+                           , wireTag :: WireTag+                           , wireTagLength :: Int64           -- ^ Bytes required in the Varint formatted wireTag+                           , isRequired :: Bool+                           , canRepeat :: Bool+                           , typeCode :: FieldType            -- ^ fromEnum of Text.DescriptorProtos.FieldDescriptorProto.Type+                           , typeName :: Maybe String+                           , hsRawDefault :: Maybe ByteString -- ^ crappy, perhaps escaped, thing+                           , hsDefault :: Maybe HsDefault     -- ^ nice parsed thing+                           }+  deriving (Show,Read,Eq,Ord,Data,Typeable)++-- | 'HsDefault' stores the parsed default from the proto file in a+-- form that will make a nice literal in the+-- Language.Haskell.Exts.Syntax sense.+data HsDefault = HsDef'Bool Bool+               | HsDef'ByteString ByteString+               | HsDef'Rational Rational+               | HsDef'Integer Integer+  deriving (Show,Read,Eq,Ord,Data,Typeable)++data EnumInfo = EnumInfo { enumName :: ProtoName+                         , enumItems :: [(EnumCode,String)]+                         }+  deriving (Show,Read,Eq,Ord,Data,Typeable)++type EnumInfoApp e = [(EnumCode,String,e)]++class ReflectDescriptor m where+  getMessageInfo :: m -> GetMessageInfo           -- Must not inspect argument+  getMessageInfo x = cached where cached = makeMessageInfo (reflectDescriptorInfo (undefined `asTypeOf` x))+  reflectDescriptorInfo :: m -> DescriptorInfo    -- Must not inspect argument+  parentOfDescriptor :: m -> Maybe DescriptorInfo -- Must not inspect argument+  parentOfDescriptor _ = Nothing++class ReflectEnum e where+  reflectEnum :: EnumInfoApp e+  reflectEnumInfo :: e -> EnumInfo            -- Must not inspect argument+  parentOfEnum :: e -> Maybe DescriptorInfo   -- Must not inspect argument+  parentOfEnum _ = Nothing++makeMessageInfo :: DescriptorInfo -> GetMessageInfo+makeMessageInfo di = GetMessageInfo { requiredTags = Set.fromDistinctAscList . sort $+                                        [ wireTag f | f <- F.toList (fields di), isRequired f]+                                    , allowedTags = Set.fromDistinctAscList . sort $+                                        [ wireTag f | f <- F.toList (fields di)]+                                    }++--- From here down is code used to parse the format of the default values in the .proto files++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++parseDefDouble :: ByteString -> Maybe HsDefault+parseDefDouble bs = fmap (HsDef'Rational . toRational) +                    . mayRead reads' . U.toString $ bs+  where reads' :: ReadS Double+        reads' = readSigned' reads++parseDefFloat :: ByteString -> Maybe HsDefault+parseDefFloat bs = fmap  (HsDef'Rational . toRational) +                   . mayRead reads' . U.toString $ bs+  where reads' :: ReadS Float+        reads' = readSigned' reads++parseDefString :: ByteString -> Maybe HsDefault+parseDefString bs = Just (HsDef'ByteString bs)++parseDefBytes :: ByteString -> Maybe HsDefault+parseDefBytes bs = Just . HsDef'ByteString +                   . BS.pack . cDecode . BSC.unpack $ bs+parseDefInteger :: ByteString -> Maybe HsDefault+parseDefInteger bs = fmap HsDef'Integer . mayRead checkSign . U.toString $ bs+    where checkSign = readSigned' checkBase+          checkBase ('0':'x':xs) = readHex xs+          checkBase ('0':xs) = readOct xs+          checkBase xs = readDec xs++parseDefBool :: ByteString -> Maybe HsDefault+parseDefBool bs | bs == BSC.pack "true" = Just (HsDef'Bool True)+                | bs == BSC.pack "false" = Just (HsDef'Bool False)+                | otherwise = Nothing++-- The Numeric.readSigned does not handle '+' for some odd reason+readSigned' f ('-':xs) = map (\(v,s) -> (-v,s)) . f $ xs+readSigned' f ('+':xs) = f xs+readSigned' f xs = f xs++-- see google's stubs/strutil.cc lines 398-449/1121 and C99 specification+-- This mainly targets three digit octal codes+cEncode :: [Word8] -> [Char]+cEncode = concatMap one where+  one :: Word8 -> [Char]+  one x | (32 < x) && (x < 127) = [toEnum .  fromEnum $  x]  -- main case of unescaped value+  one 9 = sl  't'+  one 10 = sl 'n'+  one 13 = sl 'r'+  one 34 = sl '"'+  one 39 = sl '\''+  one 92 = sl '\\'+  one 0 = '\\':"000"+  one x | x < 8 = '\\':'0':'0':(showOct x "")+        | x < 32 = '\\':'0':(showOct x "")+        | otherwise = '\\':(showOct x "")+  sl c = ['\\',c]++-- Takes backslash encoded junk an retrieves the underlying bytes+-- The \x is kosher, but \X is non-standard.  I recognize \X because google does+-- Convert backslash-escaped \u and \U crap into UTF-8 (this is why we have to use concat!)+-- It only works on characters and values in the range 0..255 (the Char8's returned by ByteString.Char.unpack)+-- It ONLY consumes up to 3 octal digits when reading an escape sequence, the rest are left alone.+cDecode :: [Char] -> [Word8]+cDecode = concat . unfoldr one where+  one :: [Char] -> Maybe ([Word8],[Char])+  one (x:xs) | x /= '\\' = Just (checkChar8 x,xs)  -- main case of unescaped value+  one [] = Nothing+  one ('\\':[]) = error "Text.ProtocolBuffers.Reflections.cDecode cannot understand ending with a backslash"+  one ('\\':ys) | 1 <= len =+      case mayRead readOct oct of+        Just w -> Just (checkByte w,rest)+        Nothing -> error "Text.ProtocolBuffers.Reflections.cDecode failed to decode octal sequence"+    where oct = takeWhile isOctDigit (take 3 ys)+          len = length oct+          rest = drop len ys+  one ('\\':x:ys) | 'x' == toLower x && ok =+      case mayRead readHex hex of+        Just w -> Just (checkByte w,rest)+        Nothing -> error "Text.ProtocolBuffers.Reflections.cDecode failed to decode hex sequence"+    where ok = 1 <= length hex+          (hex,rest) = span isHexDigit ys+  one ('\\':'u':ys) | ok =+      case mayRead readHex hex of+        Just w -> Just (checkUnicode w,rest)+        Nothing -> error "Text.ProtocolBuffers.Reflections.cDecode failed to decode 4 char unicode sequence"+    where ok = all isHexDigit hex && 4 == length hex+          (hex,rest) = splitAt 4 ys+  one ('\\':'U':ys) | ok =+      case mayRead readHex hex of+        Just w -> Just (checkUnicode w,rest)+        Nothing -> error "Text.ProtocolBuffers.Reflections.cDecode failed to decode 8 char unicode sequence"+    where ok = all isHexDigit hex && 8 == length hex+          (hex,rest) = splitAt 8 ys+  one ('\\':(x:xs)) = Just ([decode x],xs)+  decode :: Char -> Word8+  decode 'a' = 7+  decode 'b' = 8+  decode 't' = 9+  decode 'n' = 10+  decode 'v' = 11+  decode 'f' = 12+  decode 'r' = 13+  decode '\"' = 34+  decode '\'' = 39+  decode '?' = 63    -- C99 rule : "\?" is '?'+  decode '\\' = 92+  decode x | toLower x == 'x' = error "Text.ProtocolBuffers.Reflections.cDecode cannot understand your 'xX' hexadecimal escaped value"+  decode x | toLower x == 'u' = error "Text.ProtocolBuffers.Reflections.cDecode cannot understand your 'uU' unicode UTF-8 hexadecimal escaped value"+  decode _ = error "Text.ProtocolBuffers.Reflections.cDecode cannot understand your backslash-escaped value"+  checkChar8 :: Char -> [Word8]+  checkChar8 c | (0 <= i) && (i <= 255) = [toEnum i]+               | otherwise = error "Text.ProtocolBuffers.Reflections.cDecode found Char out of range 0..255"+    where i = fromEnum c+  checkByte :: Integer -> [Word8]+  checkByte i | (0 <= i) && (i <= 255) = [fromInteger i]+              | otherwise = error "Text.ProtocolBuffers.Reflections.cDecode found Oct/Hex Int out of range 0..255"+  checkUnicode :: Integer -> [Word8]+  checkUnicode i | (0 <= i) && (i <= 127) = [fromInteger i]+                 | i <= maxChar = encode [ toEnum . fromInteger $ i ]+                 | otherwise = error "Text.ProtocolBuffers.Reflections.cDecode found Unicode Char out of range 0..0x10FFFF"+    where maxChar = toInteger (fromEnum (maxBound ::Char)) -- 0x10FFFF++testEncodeDecode = let q :: [Int] -> Bool+                       q =  (\y -> let x = map (\z->abs z `mod` 255) y+                                   in  x == (map fromEnum . cDecode . cEncode . map toEnum$ x))+                   in quickCheck q
+ Text/ProtocolBuffers/Resolve.hs view
@@ -0,0 +1,200 @@+-- | Text.ProtocolBuffers.Resolve takes the output of Text.ProtocolBuffers.Parse and runs all+-- the preprocessing and sanity checks that precede Text.ProtocolBuffers.Gen creating modules.+--+-- Currently this involves mangling the names, building a NameSpace (or [NameSpace]), and making+-- all the names fully qualified (and setting TYPE_MESSAGE or TYPE_ENUM) as appropriate.+-- Field names are also checked against a list of reserved words, appending a single quote+-- to disambiguate.+-- All names from Parser should start with a letter, but _ is also handled by replacing with U' or u'.+-- Anything else will trigger a "subborn ..." error.+-- Name resolution failure are not handled elegantly: it will kill the system with a long error message.+--+-- TODO: treat names with leading "." as already "fully-qualified"+--       make sure the optional fields that will be needed are not Nothing+module Text.ProtocolBuffers.Resolve(resolveFDP) where++import qualified Text.DescriptorProtos.DescriptorProto                as D(DescriptorProto)+import qualified Text.DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))+import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto)+import qualified Text.DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D(EnumValueDescriptorProto(EnumValueDescriptorProto))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto(FieldDescriptorProto))+import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type)+import           Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto.Type(Type(..))+import qualified Text.DescriptorProtos.FieldOptions                   as D(FieldOptions)+import qualified Text.DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))+import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto)+import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..))+import qualified Text.DescriptorProtos.FileOptions                    as D.FileOptions(FileOptions(..))+import qualified Text.DescriptorProtos.MessageOptions                 as D.MessageOptions(MessageOptions(..))+import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto(MethodDescriptorProto))+import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..))+import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D.ServiceDescriptorProto(ServiceDescriptorProto(..))++import Text.ProtocolBuffers.Header+import Text.ProtocolBuffers.Parser++import Control.Monad+import Data.Char+import qualified Data.Foldable as F+import qualified Data.Traversable as T+import Data.Maybe+import Data.Map(Map)+import qualified Data.Map as M+import Data.List(unfoldr,span,inits,foldl')+import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Data.ByteString.Lazy.Char8 as LC++err s = error $ "Text.ProtocolBuffers.Resolve fatal error encountered, message:\n"++indent s+  where indent = unlines . map (\s -> ' ':' ':s) . lines++newlineBefore s = go where+  go [] = []+  go (x:xs) | x `elem` s = '\n':x:go xs+            | otherwise = x:go xs++encodeModuleNames :: [String] -> ByteString+encodeModuleNames [] = mempty+encodeModuleNames xs = U.fromString . foldr1 (\a b -> a ++ '.':b) $ xs++mangleModuleNames :: ByteString -> [String]+mangleModuleNames bs = map mangleModuleName . splitDot . U.toString $ bs ++mangleCap :: Maybe ByteString -> [String]+mangleCap = mangleModuleNames . fromMaybe mempty++mangleCap1 :: Maybe ByteString -> String+mangleCap1 = mangleModuleName . U.toString . fromMaybe mempty++splitDot :: String -> [String]+splitDot = unfoldr s where+  s ('.':xs) = s xs+  s [] = Nothing+  s xs = Just (span ('.'/=) xs)++mangleModuleName :: String -> String+mangleModuleName [] = "Empty'Name"+mangleModuleName ('_':xs) = "U'"++xs+mangleModuleName (x:xs) | isLower x = let x' = toUpper x+                                      in if isLower x' then error ("subborn lower case"++show (x:xs))+                                           else x': xs+mangleModuleName xs = xs++mangleFieldName :: Maybe ByteString -> Maybe ByteString+mangleFieldName = fmap (U.fromString . fixname . U.toString)+  where fixname [] = "empty'name"+        fixname ('_':xs) = "u'"++xs+        fixname (x:xs) | isUpper x = let x' = toLower x+                                     in if isUpper x' then error ("stubborn upper case: "++show (x:xs))+                                          else fixname (x':xs)+        fixname xs | xs `elem` reserved = xs ++ "'"+        fixname xs = xs++reserved :: [String]+reserved = ["case","class","data","default","deriving","do","else"+           ,"if","import","in","infix","infixl","infixr","instance"+           ,"let","module","newtype","of","then","type","where"] -- also reserved is "_"++newtype NameSpace = NameSpace {unNameSpace::(Map String ([String],NameType,Maybe NameSpace))}+  deriving (Show,Read)+data NameType = Message | Enumeration | Void+  deriving (Show,Read)++type Context = [NameSpace]+type Resolver = Context -> ByteString -> ByteString++seeContext :: Context -> [String] +seeContext cx = map ((++"[]") . concatMap (\k -> show k ++ ", ") . M.keys . unNameSpace) cx++data Box a = Box a+instance Show (Box a) where show (Box {}) = "Box"+test = do+  (Right fdp) <- pbParse filename2+  return (Box (fdp,resolveFDP fdp))++resolveFDP :: D.FileDescriptorProto -> D.FileDescriptorProto+resolveFDP protoIn =+  let prefix = mangleCap . msum $+                 [ D.FileOptions.java_outer_classname =<< (D.FileDescriptorProto.options protoIn)+                 , D.FileOptions.java_package =<< (D.FileDescriptorProto.options protoIn)+                 , D.FileDescriptorProto.package protoIn]+      -- Make top-most root NameSpace+      nameSpace = fromMaybe (NameSpace mempty) $ foldr addPrefix protoNames $ zip prefix (tail (inits prefix))+        where addPrefix (s1,ss) ns = Just . NameSpace $ M.singleton s1 (ss,Void,ns)+              protoNames | null protoMsgs = Nothing+                         | otherwise = Just . NameSpace . M.fromList $ protoMsgs+                where protoMsgs = F.foldr ((:) . msgNames prefix) protoEnums (D.FileDescriptorProto.message_type protoIn)+                      protoEnums = F.foldr ((:) . enumNames prefix) [] (D.FileDescriptorProto.enum_type protoIn)+                      msgNames context dIn =+                        let s1 = mangleCap1 (D.DescriptorProto.name dIn)+                            ss' = context ++ [s1]+                            dNames | null dMsgs = Nothing+                                   | otherwise = Just . NameSpace . M.fromList $ dMsgs+                            dMsgs = F.foldr ((:) . msgNames ss') dEnums (D.DescriptorProto.nested_type dIn)+                            dEnums = F.foldr ((:) . enumNames ss') [] (D.DescriptorProto.enum_type dIn)+                        in ( s1 , (ss',Message,dNames) )+                      enumNames context eIn =+                        let s1 = mangleCap1 (D.EnumDescriptorProto.name eIn)+                        in ( s1 , (context ++ [s1],Enumeration,Nothing) )+      -- Context stack for resolving the top level declarations+      protoContext :: Context+      protoContext = foldl' (\nss@(NameSpace ns:_) pre -> case M.lookup pre ns of+                                                            Just (_,Void,Just ns1) -> (ns1:nss)+                                                            _ -> nss) [nameSpace] prefix+      descend :: Context -> Maybe ByteString -> Context+      descend cx@(NameSpace n:_) name =+        case M.lookup mangled n of+          Just (_,_,Nothing) -> cx+          Just (_,_,Just ns1) -> ns1:cx+          x -> error $ "Name resolution failed:\n"++unlines (mangled : show x : "KNOWN NAMES" : seeContext cx)+       where mangled = mangleCap1 name+      resolve :: Context -> Maybe ByteString -> Maybe ByteString+      resolve context bsIn = fmap fst (resolve2 context bsIn)+      resolve2 :: Context -> Maybe ByteString -> Maybe (ByteString,NameType)+      resolve2 context Nothing = Nothing+      resolve2 context bsIn = let nameIn = mangleCap bsIn+                                  resolver [] (NameSpace cx) = error $ "resolve2.resolver []\n"++unlines [show bsIn,show nameIn,show (M.keys cx)]+                                  resolver [name] (NameSpace cx) =+                                    case M.lookup name cx of+                                      Nothing -> Nothing+                                      Just (fqName,nameType,_) -> Just (encodeModuleNames fqName,nameType)+                                  resolver (name:rest) (NameSpace cx) =+                                    case M.lookup name cx of+                                      Nothing -> Nothing+                                      Just (_,_,Nothing) -> Nothing+                                      Just (_,_,Just cx') -> resolver rest cx'+                              in msum . map (resolver nameIn) $ context+      processFDP fdp = fdp+        { D.FileDescriptorProto.message_type=fmap (processMSG protoContext) (D.FileDescriptorProto.message_type fdp)+        , D.FileDescriptorProto.enum_type=fmap (processENM protoContext) (D.FileDescriptorProto.enum_type fdp)+        , D.FileDescriptorProto.service=fmap (processSRV protoContext) (D.FileDescriptorProto.service fdp)+        , D.FileDescriptorProto.extension=fmap (processFLD protoContext Nothing) (D.FileDescriptorProto.extension fdp) }+      processMSG cx msg = msg+        { D.DescriptorProto.name=self+        , D.DescriptorProto.field=fmap (processFLD cx' self) (D.DescriptorProto.field msg)+        , D.DescriptorProto.extension=fmap (processFLD cx' self) (D.DescriptorProto.extension msg)+        , D.DescriptorProto.nested_type=fmap (processMSG cx') (D.DescriptorProto.nested_type msg)+        , D.DescriptorProto.enum_type=fmap (processENM cx') (D.DescriptorProto.enum_type msg) }+       where cx' = descend cx (D.DescriptorProto.name msg)+             self = resolve cx (D.DescriptorProto.name msg)+      processFLD cx mp f = f { D.FieldDescriptorProto.name=mangleFieldName (D.FieldDescriptorProto.name f)+                             , D.FieldDescriptorProto.type'=(D.FieldDescriptorProto.type' f) `mplus` (fmap (t.snd) r2)+                             , D.FieldDescriptorProto.type_name=checkSelf mp (fmap fst r2)+                             , D.FieldDescriptorProto.extendee=resolve cx (D.FieldDescriptorProto.extendee f) }+       where r2 = resolve2 cx (D.FieldDescriptorProto.type_name f)+             t Message = TYPE_MESSAGE+             t Enumeration = TYPE_ENUM+             t Void = error "processFLD cannot resolve type_name to Void"+             checkSelf (Just parent) x@(Just name) = if parent==name then (D.FieldDescriptorProto.type_name f) else x+             checkSelf _ x = x+      processENM cx e = e { D.EnumDescriptorProto.name=resolve cx (D.EnumDescriptorProto.name e) }+      processSRV cx s = s { D.ServiceDescriptorProto.name=resolve cx (D.ServiceDescriptorProto.name s)+                          , D.ServiceDescriptorProto.method=fmap (processMTD cx) (D.ServiceDescriptorProto.method s) }+      processMTD cx m = m { D.MethodDescriptorProto.name=mangleFieldName (D.MethodDescriptorProto.name m)+                          , D.MethodDescriptorProto.input_type=resolve cx (D.MethodDescriptorProto.input_type m)+                          , D.MethodDescriptorProto.output_type=resolve cx (D.MethodDescriptorProto.output_type m) }+  in processFDP protoIn
Text/ProtocolBuffers/WireMessage.hs view
@@ -1,43 +1,490 @@-module Text.ProtocolBuffers.WireMessage where+-- http://code.google.com/apis/protocolbuffers/docs/encoding.html+{- | This module cooperates with the generated code to implement the+  Wire instances.  + -}+module Text.ProtocolBuffers.WireMessage+    ( LazyResult(..),runGetOnLazy,runPut,size'Varint+    , Wire(..)+    , size,lenSize,putSize+    , wireSizeReq,wireSizeOpt,wireSizeRep+    , wirePutReq,wirePutOpt,wirePutRep+    , getMessage,getBareMessage+    , unknownField) where -import Data.Map+import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Reflections(ReflectDescriptor(reflectDescriptorInfo,getMessageInfo)+                                       ,DescriptorInfo(..),GetMessageInfo(..))+import Text.ProtocolBuffers.Mergeable(Mergeable(mergeEmpty)) -{- The point of this module:+import Data.Bits (Bits(..))+import Data.Generics (Data(..),Typeable(..))+import Data.List (unfoldr,genericLength)+import Data.Map (Map,unionWith)+import Data.Monoid (Monoid(..))+import Data.Word (Word8)+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.ByteString.Lazy as BS (length,pack,fromChunks)+import qualified Data.ByteString.Lazy.Internal as BS (ByteString(Empty,Chunk),chunk)+import qualified Data.Foldable as F(foldl',forM_)+import qualified Data.Sequence as Seq(length)+import qualified Data.Set as Set(notMember,delete,null)+-- GHC internals for getting at Double and Float representation as Word64 and Word32+import GHC.Exts (Double(D#),Float(F#),unsafeCoerce#)+import GHC.Word (Word64(W64#),Word32(W32#)) -There needs to be a way to represent the bytes in a form that is-in-between the type specific messages and the single string of bytes.+import Data.Binary.Put (Put,putWord8,putWord32be,putWord64be,putLazyByteString,runPut)+import Data.Binary.Builder (Builder)+import Data.Binary.Strict.Class (BinaryParser(getWord8,getWord32be,getWord64be,getByteString,bytesRead,isEmpty))+import qualified Data.Binary.Strict.IncrementalGet as Get (Get,runGet,Result(..)) -Encoding and Deconding WireMessage does not respect ordering between-different FieldId but must respect ordering of repeated FieldId-values.+-- import qualified Data.ByteString.Lazy as BS (unpack)+-- import Numeric -Converting WireData to and from the actual types (e.g. sint64) will be-done elsewhere.+-- Make IncrementalGet run on the Lazy ByteStrings+data LazyResult r = Failed String+                  | Finished ByteString r+                  | Partial (ByteString -> LazyResult r) -Converting a WireData to a message type will require code generation-of a class instance.+runGetOnLazy :: Get.Get r r -> ByteString -> LazyResult r+runGetOnLazy parser (BS.Chunk x rest) = resolve rest $ Get.runGet parser x+runGetOnLazy parser BS.Empty = resolve BS.Empty $ Get.runGet parser mempty +resolve :: ByteString -> Get.Result r -> LazyResult r+resolve _rest (Get.Failed s)              = Failed s+resolve rest (Get.Finished b s)           = Finished (BS.chunk b rest) s+resolve (BS.Chunk x rest) (Get.Partial f) = resolve rest (f x)+resolve BS.Empty (Get.Partial f)          = newPartial+  where newPartial= Partial f'+        f' BS.Empty = newPartial+        f' (BS.Chunk x rest) = resolve rest (f x)+++data WireSize = WireSize { childSize, internalSize :: !Int64 }++-- The first Int argument is fromEnum on+-- Text.DescriptorProtos.FieldDescriptorProto.Type.  The values of the+-- Int parameters cannot change without breaking all serialized+-- protocol buffers.+class Wire b where+  {-# INLINE wireSize #-}+  wireSize :: FieldType -> b -> WireSize+  {-# INLINE wirePut #-}+  wirePut :: FieldType -> b -> Put+  {-# INLINE wireGet #-}+  wireGet :: BinaryParser get => FieldType -> get b++{-# INLINE wirePutReq #-}+wirePutReq :: Wire b => WireTag -> FieldType -> b -> Put+wirePutReq wireTag fieldType b = putVarUInt (getWireTag wireTag) >> wirePut fieldType b++{-# INLINE wirePutOpt #-}+wirePutOpt :: Wire b => WireTag -> FieldType -> Maybe b -> Put+wirePutOpt wireTag fieldType Nothing = return ()+wirePutOpt wireTag fieldType (Just b) = putVarUInt (getWireTag wireTag) >> wirePut fieldType b ++{-# INLINE wirePutRep #-}+wirePutRep :: Wire b => WireTag -> FieldType -> Seq b -> Put+wirePutRep wireTag fieldType bs = F.forM_ bs (\b -> putVarUInt (getWireTag wireTag) >> wirePut fieldType b)++{-# INLINE wireSizeReq #-}+wireSizeReq :: Wire b => Int64 -> FieldType -> b -> Int64+wireSizeReq tagSize i v = tagSize + childSize (wireSize i v)++{-# INLINE wireSizeOpt #-}+wireSizeOpt :: Wire b => Int64 -> FieldType -> Maybe b -> Int64+wireSizeOpt tagSize i = maybe 0 (wireSizeReq tagSize i)++{-# INLINE wireSizeRep #-}+wireSizeRep :: Wire b => Int64 -> FieldType -> Seq b -> Int64+wireSizeRep tagSize i s = tagSize*(fromIntegral (Seq.length s)) + F.foldl' (\n v -> n+childSize(wireSize i v)) 0 s++putSize :: WireSize -> Put+putSize (WireSize {internalSize = x}) = putVarUInt x++-- getMessage assumes the wireTag for the message, if it existed, has already been read.+-- getMessage assumes that it still needs to read the Varint encoded length of the message.+getMessage :: forall get message. (BinaryParser get, Mergeable message, ReflectDescriptor message)+           => (FieldId -> message -> get message)+           -> get message+getMessage updater = do+  messageLength <- getVarInt+  start <- bytesRead+  let stop = messageLength+start+      -- switch from go to go' once all the required fields have been found+      go reqs message | Set.null reqs = go' message+                      | otherwise = do+        here <- bytesRead+        case compare stop here of+          EQ -> notEnoughData messageLength start+          LT -> tooMuchData messageLength start here+          GT -> do+            wireTag <- fmap WireTag getVarInt -- get tag off wire+            let (fieldId,wireType) = splitWireTag wireTag+            if Set.notMember wireTag allowed then unknown fieldId wireType here+              else let reqs' = Set.delete wireTag reqs+                   in updater fieldId message >>= go reqs'+      go' message = do+        here <- bytesRead+        case compare stop here of+          EQ -> return message+          LT -> tooMuchData messageLength start here+          GT -> do+            wireTag <- fmap WireTag getVarInt -- get tag off wire+            let (fieldId,wireType) = splitWireTag wireTag+            if Set.notMember wireTag allowed then unknown fieldId wireType here+              else updater fieldId message >>= go'+  go required initialMessage+ where+  initialMessage = mergeEmpty+  (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage+  splitWireTag :: WireTag -> (FieldId,WireType)+  splitWireTag (WireTag wireTag) = ( FieldId . fromIntegral $ wireTag `shiftR` 3+                                   , WireType . fromIntegral $ wireTag .&. 7 )+  unknown fieldId wireType here =+      fail ("Text.ProtocolBuffers.WireMessage.getMessage: Unknown wire tag read (fieldId,wireType,here) == "+            ++ show (fieldId,wireType,here) ++ " when processing "+            ++ (show . descName . reflectDescriptorInfo $ initialMessage))+  notEnoughData messageLength start =+      fail ("Text.ProtocolBuffers.WireMessage.getMessage: Required fields missing when processing "+            ++ (show . descName . reflectDescriptorInfo $ initialMessage)+            ++ " at (messageLength,start) == " ++ show (messageLength,start))+  tooMuchData messageLength start here =+      fail ("Text.ProtocolBuffers.WireMessage.getMessage : overran expected length when processing"+            ++ (show . descName . reflectDescriptorInfo $ initialMessage)+            ++ " at  (messageLength,start,here) == " ++ show (messageLength,start,here))++-- getBareMessage assumes the wireTag for the message, if it existed, has already been read.+-- getBareMessage assumes that it does needs to read the Varint encoded length of the message.+-- getBareMessage will consume the entire ByteString it is operating on.+getBareMessage :: forall get message. (BinaryParser get, Mergeable message, ReflectDescriptor message)+           => (FieldId -> message -> get message)+           -> get message+getBareMessage updater = go required initialMessage+ where+  go reqs message | Set.null reqs = go' message+                  | otherwise = do+    done <- isEmpty+    if done then notEnoughData+      else do+        wireTag <- fmap WireTag getWord32be -- get tag off wire+        let (fieldId,wireType) = splitWireTag wireTag+        if Set.notMember wireTag allowed then unknown fieldId wireTag+          else let reqs' = Set.delete wireTag reqs+               in updater fieldId message >>= go reqs'+  go' message = do+    done <- isEmpty+    if done then return message+      else do+        wireTag <- fmap WireTag getWord32be -- get tag off wire+        let (fieldId,wireType) = splitWireTag wireTag+        if Set.notMember wireTag allowed then unknown fieldId wireType+          else updater fieldId message >>= go'+  initialMessage = mergeEmpty+  (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage+  splitWireTag :: WireTag -> (FieldId,WireType)+  splitWireTag (WireTag wireTag) = ( FieldId . fromIntegral $ wireTag `shiftR` 3+                                   , WireType . fromIntegral $ wireTag .&. 7 )+  unknown fieldId wireType = fail ("Text.ProtocolBuffers.WireMessage.getBareMessage: Unknown wire tag read: "+                                   ++ show (fieldId,wireType) ++ " when processing "+                                   ++ (show . descName . reflectDescriptorInfo $ initialMessage))+  notEnoughData = fail ("Text.ProtocolBuffers.WireMessage.getBareMessage: Required fields missing when processing "+                        ++ (show . descName . reflectDescriptorInfo $ initialMessage))++unknownField :: (BinaryParser get) => FieldId -> get a+unknownField fieldId = do +  here <- bytesRead+  fail ("Impossible? Text.ProtocolBuffers.WireMessage.unknownField "+        ++" The Message's updater claims there is an unknown field id on wire: "++show fieldId+        ++" at a position just before here == "++show here)++-- | 'size' takes the length of a primitive which is the same+-- internally and as a child of a message+size :: Int64 -> WireSize+size n = WireSize {childSize = n, internalSize = n}++-- | 'lenSize' takes the length of a bare message and adds its encoded+-- size as a header to get the 'childSize'.+lenSize :: Int64 -> WireSize+lenSize n = WireSize {childSize = n+size'Varint n, internalSize = n}++instance Wire Double where+  wireSize {- TYPE_DOUBLE -} 1     _ = size $ 8+  wirePut {- TYPE_DOUBLE -} 1 (D# d) = putWord64be (W64# (unsafeCoerce# d))+  wireGet {- TYPE_DOUBLE -} 1        = fmap (\(W64# w) -> D# (unsafeCoerce# w)) getWord64be++instance Wire Float where+  wireSize {- TYPE_FLOAT -} 2      _ = size $ 4+  wirePut {- TYPE_FLOAT -} 2  (F# f) = putWord32be (W32# (unsafeCoerce# f))+  wireGet {- TYPE_FLOAT -} 2         = fmap (\(W32# w) -> F# (unsafeCoerce# w)) getWord32be++instance Wire Int64 where+  wireSize {- TYPE_INT64 -} 3      x = size $ size'Varint x+  wireSize {- TYPE_SINT64 -} 18    x = size $ size'Varint (zzEncode64 x)+  wireSize {- TYPE_SFIXED64 -} 16  _ = size $ 8+  wirePut {- TYPE_INT64 -} 3       x = putVarSInt x+  wirePut {- TYPE_SINT64 -} 18     x = putVarUInt (zzEncode64 x)+  wirePut {- TYPE_SFIXED64 -} 16   x = putWord64be (fromIntegral x)+  wireGet {- TYPE_INT64 -} 3         = getVarInt+  wireGet {- TYPE_SINT64 -} 18       = fmap zzDecode64 getVarInt+  wireGet {- TYPE_SFIXED64 -} 16     = fmap fromIntegral getWord64be++instance Wire Int32 where+  wireSize {- TYPE_INT32 -} 5      x = size $ size'Varint x+  wireSize {- TYPE_SINT32 -} 17    x = size $ size'Varint (zzEncode32 x)+  wireSize {- TYPE_SFIXED32 -} 15  _ = size $ 4+  wirePut {- TYPE_INT32 -} 5       x = putVarSInt x+  wirePut {- TYPE_SINT32 -} 17     x = putVarUInt (zzEncode32 x)+  wirePut {- TYPE_SFIXED32 -} 15   x = putWord32be (fromIntegral x)+  wireGet {- TYPE_INT32 -} 5         = getVarInt+  wireGet {- TYPE_SINT32 -} 17       = fmap zzDecode32 getVarInt+  wireGet {- TYPE_SFIXED32 -} 15     = fmap fromIntegral getWord32be++instance Wire Word64 where+  wireSize {- TYPE_UINT64 -} 4     x = size $ size'Varint x+  wireSize {- TYPE_FIXED64 -} 6    _ = size $ 8+  wirePut {- TYPE_UINT64 -} 4      x = putVarUInt x+  wirePut {- TYPE_FIXED64 -} 6     x = putWord64be x+  wireGet {- TYPE_UINT64 -} 4        = getVarInt+  wireGet {- TYPE_FIXED64 -} 6       = getWord64be++instance Wire Word32 where+  wireSize {- TYPE_UINT32 -} 13    x = size $ size'Varint x+  wireSize {- TYPE_FIXED32 -} 7    _ = size $ 4+  wirePut {- TYPE_UINT32 -} 13     x = putVarUInt x+  wirePut {- TYPE_FIXED32 -} 7     x = putWord32be x+  wireGet {- TYPE_UINT32 -} 13       = getVarInt+  wireGet {- TYPE_FIXED32 -} 7       = getWord32be++instance Wire Bool where+  wireSize {- TYPE_BOOL -} 8       _ = size $ 1+  wirePut {- TYPE_BOOL -} 8    False = putWord8 0+  wirePut {- TYPE_BOOL -} 8    True  = putWord8 1 -- google's wire_format_inl.h+  wireGet {- TYPE_BOOL -} 8          = do+    (x :: Word32) <- getVarInt -- google's wire_format_inl.h line 97+    case x of+      0 -> return False+      x | x < 128 -> return True+      _ -> fail ("TYPE_BOOL read failure : " ++ show x)++instance Wire ByteString where+-- items of TYPE_STRING is already in a UTF8 encoded Data.ByteString.Lazy+-- items of TYPE_BYTES is an untyped binary Data.ByteString.Lazy+  wireSize {- TYPE_STRING -} 9     x = lenSize $ BS.length x+  wireSize {- TYPE_BYTES -} 12     x = lenSize $ BS.length x+  wirePut {- TYPE_STRING -} 9      x = putVarUInt (BS.length x) >> putLazyByteString x+  wirePut {- TYPE_BYTES -} 12      x = putVarUInt (BS.length x) >> putLazyByteString x+  wireGet {- TYPE_STRING -} 9        = getVarInt >>= getByteString >>= return . toLazy --getLazyByteString +  wireGet {- TYPE_BYTES -} 12        = getVarInt >>= getByteString >>= return . toLazy --getLazyByteString++-- Wrap a protocol-buffer Enum in fromEnum or toEnum and serialize the Int:+instance Wire Int where+  wireSize {- TYPE_ENUM -} 14      x = size $ size'Varint x+  wirePut {- TYPE_ENUM -} 14       x = putVarUInt x+  wireGet {- TYPE_ENUM -} 14         = getVarInt++toLazy :: Strict.ByteString -> ByteString+toLazy = BS.fromChunks . (:[])++-- TYPE_GROUP 10+-- TYPE_MESSAGE 11+-- -- ++-- This will have to examine the value of positive numbers to get the size+{-# INLINE size'Varint #-}+size'Varint :: (Bits a,Integral a) => a -> Int64+size'Varint b = case compare b 0 of+                  LT -> fromIntegral (divBy (bitSize b) 7)+                  EQ -> 1+                  GT -> genericLength . takeWhile (0<) . iterate (`shiftR` 7) $ b++{-# INLINE divBy #-}+divBy :: (Ord a, Integral a) => a -> a -> a+divBy a b = let (q,r) = quotRem (abs a) b+            in if r==0 then q else succ q++-- Taken from google's code, but I had to explcitly add fromIntegral in the right places:+zzEncode32 :: Int32 -> Word32+zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 31))+zzEncode64 :: Int64 -> Word64+zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63))+zzDecode32 :: Word32 -> Int32+zzDecode32 w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1)))+zzDecode64 :: Word64 -> Int64+zzDecode64 w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1)))++-- The above is tricky, so the testing roundtrips and versus examples is needed:+testZZ = and (concat testsZZ)+  where testsZZ = [ map (\v -> v ==zzEncode64 (zzDecode64 v)) values+                  , map (\v -> v ==zzEncode32 (zzDecode32 v)) values+                  , map (\v -> v ==zzDecode64 (zzEncode64 v)) values+                  , map (\v -> v ==zzDecode32 (zzEncode32 v)) values+                  , [ zzEncode32 minBound == maxBound+                    , zzEncode32 maxBound == pred maxBound+                    , zzEncode64 minBound == maxBound+                    , zzEncode64 maxBound == pred maxBound+                    , zzEncode64 0 == 0,    zzEncode32 0 == 0+                    , zzEncode64 (-1) == 1, zzEncode32 (-1) == 1+                    , zzEncode64 1 == 2,    zzEncode32 1 == 2+                    ] ]+        values :: (Bounded a,Integral a) => [a]+        values = [minBound,div minBound 2,-3,-2,-1,0,1,2,3,div maxBound 2, maxBound]++{-# INLINE getVarInt #-}+getVarInt :: (Integral a, Bits a, BinaryParser get) => get a+getVarInt = do -- optimize first read instead of calling (go 0 0)+  b <- getWord8+  if testBit b 7 then go 7 (fromIntegral (b .&. 0x7F))+    else return (fromIntegral b)+ where+  go n val = do+    b <- getWord8+    if testBit b 7 then go (n+7) (val .|. ((fromIntegral (b .&. 0x7F)) `shiftL` n))+      else return (val .|. ((fromIntegral b) `shiftL` n))++-- This can be used on any Integral type and is needed for signed types; unsigned can use putVarUInt below.+{-# INLINE putVarSInt #-}+putVarSInt :: (Integral a, Bits a) => a -> Put+putVarSInt b =+  case compare b 0 of+    LT -> let len = divBy (bitSize b) 7               -- (pred len)*7 < bitSize b <= len*7+              last'Size = (bitSize b)-((pred len)*7)  -- at least 1 and at most 7+              last'Mask = pred (1 `shiftL` last'Size) -- at least 1 and at most 255+              go i 1 = putWord8 (fromIntegral i .&. last'Mask)+              go i n = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> go (i `shiftR` 7) (pred n)+          in go b len+    EQ -> putWord8 0+    GT -> putVarUInt b++-- This should be used on unsigned Integral types only (not checked)+{-# INLINE putVarUInt #-}+putVarUInt :: (Integral a, Bits a) => a -> Put+putVarUInt b = let go i | i < 0x80 = putWord8 (fromIntegral i)+                        | otherwise = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> go (i `shiftR` 7)+               in go b++{-+-- copied from Data.Binary.Builder+-- copied from Data.ByteString.Lazy+--+defaultSize :: Int+defaultSize = 32 * k - overhead+    where k = 1024+          overhead = 2 * sizeOf (undefined :: Int)++-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.+-- The construction work takes place if and when the relevant part of+-- the lazy 'L.ByteString' is demanded.+--+toLazyByteStringSized :: Int64 -> Builder -> ByteString+toLazyByteStringSized m bytes = BS.fromChunks $ unsafePerformIO $ do+    buf <- newBuffer bytes+    return (runBuilder (m `append` flush) (const []) buf)++newBuffer :: Int -> IO Buffer+newBuffer size = do+    fp <- S.mallocByteString size+    return $! Buffer fp 0 0 size+{-# INLINE newBuffer #-}++runSizedPut :: Int64 -> Put -> ByteString+runSizedPut bytes | bytes<0 = error "runSizedPut : size cannot be negative"+                  | bytes==0 = const mempty+                  | defaultSize<=bytes = runPut+                  | otherwise = toLazyByteStringSized bytes . sndS  . unPut $ put -} -import Data.Bits(Bits(..))-import Data.Generics(Data(..),Typeable(..))-import Data.Word(Word32,Word64)-import Data.ByteString(ByteString)-import Data.Sequence(Seq)-import Data.Map(Map,unionWith)-import Data.Monoid(Monoid(..))+{- -newtype FieldId = FieldId { getFieldID :: Word32 } -- really 29 bits, 0 to 2^29-1-  deriving (Eq,Ord,Show,Data,Typeable)+{- Useful for testing -} -newtype WireId = WireId { getWireID :: Word32 } -- really 3 bits-  deriving (Eq,Ord,Show,Data,Typeable)+testVarInt :: (Integral a, Enum a, Ord a, Bits a) => a -> (Bool,[Word8],Either String a)+testVarInt i = let w = toVarInt i+               in case fromVarInt w of+                    r@(Right v) -> (v==i,w,r)+                    l -> (False,w,l) -data WireData = Fix4 Word32 -              | Fix8 Word32 -- 4 and 8 byte fixed length types, lsb first on wire-              | VarInt ByteString -- the 128 bit variable encoding (least significant first)+fromVarInt :: (Integral a, Bits a) => [Word8] -> Either String a+fromVarInt [] = Left "No bytes!"+fromVarInt (b:bs) = do+  if testBit b 7 then go bs 7 (fromIntegral (b .&. 0x7F))+    else if null bs then Right (fromIntegral b)+           else Left ("Excess bytes: " ++ show (b,bs))+ where+  go [] n val = Left ("Not enough bytes: " ++ show (n,val))+  go (b:bs) n val = do+    if testBit b 7 then go bs (n+7) (val .|. ((fromIntegral (b .&. 0x7F)) `shiftL` n))+      else if null bs then Right (val .|. ((fromIntegral b) `shiftL` n))+             else Left ("Excess bytes: " ++ show (b,bs,n,val))++toVarInt :: (Integral a, Bits a) => a -> [Word8]+toVarInt b = case compare b 0 of+               LT -> let len = divBy (bitSize b) 7+                         last'Size = (bitSize b) - ((pred len)*7)+                         last'Mask = pred (1 `shiftL` last'Size)+                         go i 1 = [fromIntegral i .&. last'Mask]+                         go i n = (fromIntegral (i .&. 0x7F) .|. 0x80) : go (i `shiftR` 7) (pred n)+                     in go b len+               EQ -> [0]+               GT -> let go i | i < 0x80 = [fromIntegral i]+                              | otherwise = (fromIntegral (i .&. 0x7F) .|. 0x80) : go (i `shiftR` 7)+                     in go b+{-  On my G4 (big endian) powerbook:++le is the protocol-buffer standard (x86 optimized)++*Text.ProtocolBuffers.WireMessage Data.Int Data.Word Numeric> gle . cw $ fle pi+("182d4454fb210940",("word",4614256656552045848,"400921fb54442d18"),("double",3.141592653589793))++be is the network byte order standard (and native for my G4)++*Text.ProtocolBuffers.WireMessage Data.Int Data.Word Numeric> gbe . cw $ fbe pi+("400921fb54442d18",("word",4614256656552045848,"400921fb54442d18"),("double",3.141592653589793))++-}+padL n c s = let l = length s+             in replicate (n-l) c ++ s++cw = concatMap (padL 2 '0')++fbe :: Double -> [String]+fbe (D# d) = let w = W64# (unsafeCoerce# d)+                 b = Build.toLazyByteString (Build.putWord64be w)+             in map (flip showHex "") $  BS.unpack  b++fle :: Double -> [String]+fle (D# d) = let w = W64# (unsafeCoerce# d)+                 b = Build.toLazyByteString (Build.putWord64le w)+             in map (flip showHex "") $ BS.unpack  b++gbe :: [Char] -> ([Char], ([Char], Word64, String), ([Char], Double))+gbe s = let pairs = Data.List.unfoldr (\a -> if Prelude.null a then Nothing+                                               else Just (splitAt 2 a)) s+            words = map (fst . head . readHex) pairs+            w@(W64# w64) = Get.runGet Get.getWord64be (BS.pack words)+            d = D# (unsafeCoerce# w64)+        in (s,("word",w,showHex w ""),("double",d))++gle :: [Char] -> ([Char], ([Char], Word64, String), ([Char], Double))+gle s = let pairs = Data.List.unfoldr (\a -> if Prelude.null a then Nothing+                                               else Just (splitAt 2 a)) s+            words = map (fst . head . readHex) pairs+            w@(W64# w64) = Get.runGet Get.getWord64le (BS.pack words)+            d = D# (unsafeCoerce# w64)+        in (s,("word",w,showHex w ""),("double",d))++-}+++{-+-- Some to-be-reviewed-for-sanity prototypes for the bytestream reader++data WireData = VarInt ByteString -- the 128 bit variable encoding (least significant first)+              | Fix8 ByteString -- 4 and 8 byte fixed length types, lsb first on wire               | VarString ByteString -- length of contents as a VarInt-                          ByteString -- the contents on the wire+              |           ByteString -- the contents on the wire+              | StartGroup+              | StopGroup+              | Fix4 ByteString   deriving (Eq,Ord,Show,Data,Typeable)  newtype WireMessage = WireMessage (Map FieldId (Seq WireData))@@ -46,17 +493,19 @@   mempty = WireMessage mempty   mappend (WireMessage a) (WireMessage b) = WireMessage (unionWith mappend a b) -wireId :: WireData -> WireId-wireId  (Fix4 {}) = WireId 5-wireId  (Fix8 {}) = WireId 1-wireId  (VarInt {}) = WireId 0-wireId  (VarString {}) = WireId 2+wireId :: WireData -> WireType+wireId (VarInt {})    = WireType 0+wireId (Fix8 {})      = WireType 1+wireId (VarString {}) = WireType 2+wireId  StartGroup    = WireType 3+wireId  StopGroup     = WireType 4+wireId (Fix4 {})      = WireType 5 -composeFieldWire :: FieldId -> WireId -> Word32-composeFieldWire (FieldId f) (WireId w) = (f `shiftL` 3) .|. w+composeFieldWire :: FieldId -> WireType -> Word32+composeFieldWire (FieldId f) (WireType w) = ((fromIntegral f) `shiftL` 3) .|. w -decomposeFieldWire :: Word32 -> (FieldId,WireId)-decomposeFieldWire x = (FieldId (x `shiftR` 3), WireId (x .&. 7))+decomposeFieldWire :: Word32 -> (FieldId,WireType)+decomposeFieldWire x = (FieldId (fromIntegral (x `shiftR` 3)), WireType (x .&. 7))  encodeWireMessage :: WireMessage -> ByteString encodeWireMessage = undefined@@ -64,3 +513,4 @@ decodeWireMessage :: ByteString -> WireMessage decodeWireMessage = undefined +-}
+ Text/ProtocolBuffers/testDepth view
@@ -0,0 +1,204 @@+-- Annotated run of MyGetW.testDepth++[1 of 1] Compiling Text.ProtocolBuffers.MyGetW ( /Users/chrisk/Documents/projects/haskell/develop/protocol-buffers/Text/ProtocolBuffers/MyGetW.hs, interpreted )+Ok, modules loaded: Text.ProtocolBuffers.MyGetW.+*Text.ProtocolBuffers.MyGetW> testDepth+("stack depth",0,"bytes read",0,"bytes remaining",0,"begin")+TopFrame 1 (ErrorFrame <> True)+("stack depth",1,"bytes read",0,"bytes remaining",0,"mayFail")+TopFrame 2 (HandlerFrame 1 (S {top = "", current = Empty, consumed = 0, userField = ()}) (fromList [])+  (ErrorFrame <> True))++("stack depth",0,"bytes read",0,"bytes remaining",0,"handler")+TopFrame 2 (ErrorFrame <> True)+("stack depth",0,"bytes read",0,"bytes remaining",0,"middle")+TopFrame 2 (ErrorFrame <> True)+("feed1",[48,49])+"chomp [48] <0>"+"after jump and with 0"+("stack depth",1,"bytes read",1,"bytes remaining",1,"after getCC1, inside 1 handler")+TopFrame 3 (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+  (ErrorFrame <> True))++("stack depth",2,"bytes read",1,"bytes remaining",1,"after getCC1, inside 2 handlers, before chomp")+TopFrame 4 (HandlerFrame 3 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+    (ErrorFrame <> True)))++"chomp [49] <1>"+("stack depth",2,"bytes read",2,"bytes remaining",0,"after getCC1, inside 2 handlers, after chomp")+TopFrame 4 (HandlerFrame 3 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+    (ErrorFrame <> True)))++("stack depth",3,"bytes read",2,"bytes remaining",0,"in mplus left")+TopFrame 5 (HandlerFrame 4 (S {top = "", current = Empty, consumed = 2, userField = ()}) (fromList [])+  (HandlerFrame 3 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+    (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+      (ErrorFrame <> True))))++-- The use of 'jump' here resets the writer to the chomp '1' is not in the writer output++"after jump and with 1"+("stack depth",1,"bytes read",2,"bytes remaining",0,"after getCC1, inside 1 handler")+TopFrame 5 (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+  (ErrorFrame <> True))++("stack depth",2,"bytes read",2,"bytes remaining",0,"after getCC1, inside 2 handlers, before chomp")+TopFrame 6 (HandlerFrame 5 (S {top = "", current = Empty, consumed = 2, userField = ()}) (fromList [])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [])+    (ErrorFrame <> True)))++("feed1",[50,51]) -- adds "23" to future of HandlerFrame 5 and HandlerFrame 2+"chomp [50] <2>"+("stack depth",2,"bytes read",3,"bytes remaining",1,"after getCC1, inside 2 handlers, after chomp")+TopFrame 6 (HandlerFrame 5 (S {top = "", current = Empty, consumed = 2, userField = ()}) (fromList [Chunk "23" Empty])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+    (ErrorFrame <> True)))++("stack depth",3,"bytes read",3,"bytes remaining",1,"in mplus left")+TopFrame 7 (HandlerFrame 6 (S {top = "3", current = Empty, consumed = 3, userField = ()}) (fromList [])+  (HandlerFrame 5 (S {top = "", current = Empty, consumed = 2, userField = ()}) (fromList [Chunk "23" Empty])+    (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+      (ErrorFrame <> True))))++-- this use of 'jump' resets the writer again and the '2' is removed.++"after jump and with 2"+("stack depth",1,"bytes read",3,"bytes remaining",1,"after getCC1, inside 1 handler")+TopFrame 7 (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+  (ErrorFrame <> True))++("stack depth",2,"bytes read",3,"bytes remaining",1,"after getCC1, inside 2 handlers, before chomp")+TopFrame 8 (HandlerFrame 7 (S {top = "3", current = Empty, consumed = 3, userField = ()}) (fromList [])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+    (ErrorFrame <> True)))++"chomp [51] <3>"+("stack depth",2,"bytes read",4,"bytes remaining",0,"after getCC1, inside 2 handlers, after chomp")+TopFrame 8 (HandlerFrame 7 (S {top = "3", current = Empty, consumed = 3, userField = ()}) (fromList [])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+    (ErrorFrame <> True)))++("stack depth",3,"bytes read",4,"bytes remaining",0,"in mplus left")+TopFrame 9 (HandlerFrame 8 (S {top = "", current = Empty, consumed = 4, userField = ()}) (fromList [])+  (HandlerFrame 7 (S {top = "3", current = Empty, consumed = 3, userField = ()}) (fromList [])+    (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+      (ErrorFrame <> True))))++"after jump and with 3"++-- The use of 'jump' takes the chomp '3' out of the writer log++("stack depth",1,"bytes read",4,"bytes remaining",0,"after getCC1, inside 1 handler")+TopFrame 9 (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+  (ErrorFrame <> True))++("stack depth",2,"bytes read",4,"bytes remaining",0,"after getCC1, inside 2 handlers, before chomp")+TopFrame 10 (HandlerFrame 9 (S {top = "", current = Empty, consumed = 4, userField = ()}) (fromList [])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty])+    (ErrorFrame <> True)))++("feed1",[52,53]) -- add "45" to future of HandlerFrame 9 and HandlerFrame 2+"chomp [52] <4>"+("stack depth",2,"bytes read",5,"bytes remaining",1,"after getCC1, inside 2 handlers, after chomp")+TopFrame 10 (HandlerFrame 9 (S {top = "", current = Empty, consumed = 4, userField = ()}) (fromList [Chunk "45" Empty])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty,Chunk "45" Empty])+    (ErrorFrame <> True)))++("stack depth",3,"bytes read",5,"bytes remaining",1,"in mplus left")+TopFrame 11 (HandlerFrame 10 (S {top = "5", current = Empty, consumed = 5, userField = ()}) (fromList [])+  (HandlerFrame 9 (S {top = "", current = Empty, consumed = 4, userField = ()}) (fromList [Chunk "45" Empty])+    (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty,Chunk "45" Empty])+      (ErrorFrame <> True))))++-- At this point 'mzero' goes to state in HandlerFrame 10+-- bytes read is still 5++("stack depth",2,"bytes read",5,"bytes remaining",1,"in mplus right")+TopFrame 11 (HandlerFrame 9 (S {top = "", current = Empty, consumed = 4, userField = ()}) (fromList [Chunk "45" Empty])+  (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty,Chunk "45" Empty])+    (ErrorFrame <> True)))++-- At this point the next 'mzero' goes to state in HandlerFrame 9+-- This loses chomp '4' from the writer log+-- bytes read is reduced to 4++("stack depth",1,"bytes read",4,"bytes remaining",2,"handler after getCC1")+TopFrame 11 (HandlerFrame 2 (S {top = "1", current = Empty, consumed = 1, userField = ()}) (fromList [Chunk "23" Empty,Chunk "45" Empty])+  (ErrorFrame <> True))++-- At this point the third 'mzero' goes to state in HandlerFrame 2+-- bytes read is reduced to 1+-- The last 3 mzeros have reset the input so that now all but chomp "0" have been undone++("stack depth",0,"bytes read",1,"bytes remaining",5,"handler before getCC1")+TopFrame 11 (ErrorFrame <> True)+("listen","0")+("stack depth",0,"bytes read",1,"bytes remaining",5,"another middle")+TopFrame 11 (ErrorFrame <> True)+"chomp [49] <1>"+("stack depth",1,"bytes read",2,"bytes remaining",4,"before inner jump2")+TopFrame 12 (HandlerFrame 11 (S {top = "1", current = Chunk "23" (Chunk "45" Empty), consumed = 1, userField = ()}) (fromList [])+  (ErrorFrame <> True))++("stack depth",1,"bytes read",2,"bytes remaining",4,"after inner jump2 with 0")+TopFrame 12 (HandlerFrame 11 (S {top = "1", current = Chunk "23" (Chunk "45" Empty), consumed = 1, userField = ()}) (fromList [])+  (ErrorFrame <> True))++"chomp [50] <2>"+"chomp [51] <3>"+("stack depth",0,"bytes read",4,"bytes remaining",2,"after catchError scope of jump2")+TopFrame 12 (ErrorFrame <> True)+"chomp [52] <4>"+"jump2"++-- This use of 'jump2' resets the writer, so the chomp '1' '2' '3' and '4' are not in the writer output++("stack depth",1,"bytes read",5,"bytes remaining",1,"after inner jump2 with 1")+TopFrame 12 (HandlerFrame 11 (S {top = "5", current = Empty, consumed = 5, userField = ()}) (fromList [])+  (ErrorFrame <> True))++"chomp [53] <5>"++-- At this point (throwError "Ouch") goes to HandlerFrame 11, so the last chomp "1" to "5" are out of the writer log+-- the bytes read is reduced from 6 to 5++("stack depth",0,"bytes read",5,"bytes remaining",1,"last handler")+TopFrame 12 (ErrorFrame <> True)+"chomp [53] <5>"+("stack depth",0,"bytes read",6,"bytes remaining",0,"after catchError scope of jump2")+TopFrame 12 (ErrorFrame <> True)+("feed1",[54,55])+"chomp [54] <6>"+"Nothing"+("stack depth",0,"bytes read",7,"bytes remaining",1,"end")+TopFrame 12 (ErrorFrame <> True)++ -- getByteString 6 is called++("feed1",[56,57])+("feed1",[58,59])+("feed1",[60,61])++-- getByteString 6 finishes, receiving [55..60] aka "789:;<"++("stack depth",0,"bytes read",13,"bytes remaining",1,"got 6, now suspendUntilComplete")+TopFrame 12 (ErrorFrame <> True)+("feed1",[62,63])+("feed1",[64,65])+("feed1",[66,67])+("feed1",[68,69])+("feed1",[70,71])+("feed1",[72,73])+("feed1",[74,75])+("feed1",[76,77])+("feed1",[78,79])+("feed1",[80,81])+("feed1",[82,83])+("feed1",[84,85])+("feed1",[86,87])+("feed1",[88,89])+("feed1",[90,91])+(CFinished (Chunk "=" (Chunk ">?" (Chunk "@A" (Chunk "BC" (Chunk "DE" (Chunk "FG" (Chunk "HI" (Chunk "JK" (Chunk "LM" (Chunk "NO" (Chunk "PQ" (Chunk "RS" (Chunk "TU" (Chunk "VW" (Chunk "XY" (Chunk "Z[" Empty)))))))))))))))) (13) ("056") (()) ("789:;<"))+*Text.ProtocolBuffers.MyGetW>
+ descriptor.proto view
@@ -0,0 +1,286 @@+// Protocol Buffers - Google's data interchange format+// Copyright 2008 Google Inc.+// http://code.google.com/p/protobuf/+//+// Licensed under the Apache License, Version 2.0 (the "License");+// you may not use this file except in compliance with the License.+// You may obtain a copy of the License at+//+//      http://www.apache.org/licenses/LICENSE-2.0+//+// Unless required by applicable law or agreed to in writing, software+// distributed under the License is distributed on an "AS IS" BASIS,+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+// See the License for the specific language governing permissions and+// limitations under the License.++// Author: kenton@google.com (Kenton Varda)+//  Based on original Protocol Buffers design by+//  Sanjay Ghemawat, Jeff Dean, and others.+//+// The messages in this file describe the definitions found in .proto files.+// A valid .proto file can be translated directly to a FileDescriptorProto+// without any other information (e.g. without reading its imports).++++package google.protobuf;+option java_package = "com.google.protobuf";+option java_outer_classname = "DescriptorProtos";++// descriptor.proto must be optimized for speed because reflection-based+// algorithms don't work during bootstrapping.+option optimize_for = SPEED;++// Describes a complete .proto file.+message FileDescriptorProto {+  optional string name = 1;       // file name, relative to root of source tree+  optional string package = 2;    // e.g. "foo", "foo.bar", etc.++  // Names of files imported by this file.+  repeated string dependency = 3;++  // All top-level definitions in this file.+  repeated DescriptorProto message_type = 4;+  repeated EnumDescriptorProto enum_type = 5;+  repeated ServiceDescriptorProto service = 6;+  repeated FieldDescriptorProto extension = 7;++  optional FileOptions options = 8;+}++// Describes a message type.+message DescriptorProto {+  optional string name = 1;++  repeated FieldDescriptorProto field = 2;+  repeated FieldDescriptorProto extension = 6;++  repeated DescriptorProto nested_type = 3;+  repeated EnumDescriptorProto enum_type = 4;++  message ExtensionRange {+    optional int32 start = 1;+    optional int32 end = 2;+  }+  repeated ExtensionRange extension_range = 5;++  optional MessageOptions options = 7;+}++// Describes a field within a message.+message FieldDescriptorProto {+  enum Type {+    // 0 is reserved for errors.+    // Order is weird for historical reasons.+    TYPE_DOUBLE         = 1;+    TYPE_FLOAT          = 2;+    TYPE_INT64          = 3;   // Not ZigZag encoded.  Negative numbers+                               // take 10 bytes.  Use TYPE_SINT64 if negative+                               // values are likely.+    TYPE_UINT64         = 4;+    TYPE_INT32          = 5;   // Not ZigZag encoded.  Negative numbers+                               // take 10 bytes.  Use TYPE_SINT32 if negative+                               // values are likely.+    TYPE_FIXED64        = 6;+    TYPE_FIXED32        = 7;+    TYPE_BOOL           = 8;+    TYPE_STRING         = 9;+    TYPE_GROUP          = 10;  // Tag-delimited aggregate.+    TYPE_MESSAGE        = 11;  // Length-delimited aggregate.++    // New in version 2.+    TYPE_BYTES          = 12;+    TYPE_UINT32         = 13;+    TYPE_ENUM           = 14;+    TYPE_SFIXED32       = 15;+    TYPE_SFIXED64       = 16;+    TYPE_SINT32         = 17;  // Uses ZigZag encoding.+    TYPE_SINT64         = 18;  // Uses ZigZag encoding.+  };++  enum Label {+    // 0 is reserved for errors+    LABEL_OPTIONAL      = 1;+    LABEL_REQUIRED      = 2;+    LABEL_REPEATED      = 3;+    // TODO(sanjay): Should we add LABEL_MAP?+  };++  optional string name = 1;+  optional int32 number = 3;+  optional Label label = 4;++  // If type_name is set, this need not be set.  If both this and type_name+  // are set, this must be either TYPE_ENUM or TYPE_MESSAGE.+  optional Type type = 5;++  // For message and enum types, this is the name of the type.  If the name+  // starts with a '.', it is fully-qualified.  Otherwise, C++-like scoping+  // rules are used to find the type (i.e. first the nested types within this+  // message are searched, then within the parent, on up to the root+  // namespace).+  optional string type_name = 6;++  // For extensions, this is the name of the type being extended.  It is+  // resolved in the same manner as type_name.+  optional string extendee = 2;++  // For numeric types, contains the original text representation of the value.+  // For booleans, "true" or "false".+  // For strings, contains the default text contents (not escaped in any way).+  // For bytes, contains the C escaped value.  All bytes >= 128 are escaped.+  // TODO(kenton):  Base-64 encode?+  optional string default_value = 7;++  optional FieldOptions options = 8;+}++// Describes an enum type.+message EnumDescriptorProto {+  optional string name = 1;++  repeated EnumValueDescriptorProto value = 2;++  optional EnumOptions options = 3;+}++// Describes a value within an enum.+message EnumValueDescriptorProto {+  optional string name = 1;+  optional int32 number = 2;++  optional EnumValueOptions options = 3;+}++// Describes a service.+message ServiceDescriptorProto {+  optional string name = 1;+  repeated MethodDescriptorProto method = 2;++  optional ServiceOptions options = 3;+}++// Describes a method of a service.+message MethodDescriptorProto {+  optional string name = 1;++  // Input and output type names.  These are resolved in the same way as+  // FieldDescriptorProto.type_name, but must refer to a message type.+  optional string input_type = 2;+  optional string output_type = 3;++  optional MethodOptions options = 4;+}++// ===================================================================+// Options++// Each of the definitions above may have "options" attached.  These are+// just annotations which may cause code to be generated slightly differently+// or may contain hints for code that manipulates protocol messages.++// TODO(kenton):  Allow extensions to options.++message FileOptions {++  // Sets the Java package where classes generated from this .proto will be+  // placed.  By default, the proto package is used, but this is often+  // inappropriate because proto packages do not normally start with backwards+  // domain names.+  optional string java_package = 1;+++  // If set, all the classes from the .proto file are wrapped in a single+  // outer class with the given name.  This applies to both Proto1+  // (equivalent to the old "--one_java_file" option) and Proto2 (where+  // a .proto always translates to a single class, but you may want to+  // explicitly choose the class name).+  optional string java_outer_classname = 8;++  // If set true, then the Java code generator will generate a separate .java+  // file for each top-level message, enum, and service defined in the .proto+  // file.  Thus, these types will *not* be nested inside the outer class+  // named by java_outer_classname.  However, the outer class will still be+  // generated to contain the file's getDescriptor() method as well as any+  // top-level extensions defined in the file.+  optional bool java_multiple_files = 10 [default=false];++  // Generated classes can be optimized for speed or code size.+  enum OptimizeMode {+    SPEED = 1;      // Generate complete code for parsing, serialization, etc.+    CODE_SIZE = 2;  // Use ReflectionOps to implement these methods.+  }+  optional OptimizeMode optimize_for = 9 [default=CODE_SIZE];+}++message MessageOptions {+  // Set true to use the old proto1 MessageSet wire format for extensions.+  // This is provided for backwards-compatibility with the MessageSet wire+  // format.  You should not use this for any other reason:  It's less+  // efficient, has fewer features, and is more complicated.+  //+  // The message must be defined exactly as follows:+  //   message Foo {+  //     option message_set_wire_format = true;+  //     extensions 4 to max;+  //   }+  // Note that the message cannot have any defined fields; MessageSets only+  // have extensions.+  //+  // All extensions of your type must be singular messages; e.g. they cannot+  // be int32s, enums, or repeated messages.+  //+  // Because this is an option, the above two restrictions are not enforced by+  // the protocol compiler.+  optional bool message_set_wire_format = 1 [default=false];+}++message FieldOptions {+  // The ctype option instructs the C++ code generator to use a different+  // representation of the field than it normally would.  See the specific+  // options below.  This option is not yet implemented in the open source+  // release -- sorry, we'll try to include it in a future version!+  optional CType ctype = 1;+  enum CType {+    CORD = 1;++    STRING_PIECE = 2;+  }++  // EXPERIMENTAL.  DO NOT USE.+  // For "map" fields, the name of the field in the enclosed type that+  // is the key for this map.  For example, suppose we have:+  //   message Item {+  //     required string name = 1;+  //     required string value = 2;+  //   }+  //   message Config {+  //     repeated Item items = 1 [experimental_map_key="name"];+  //   }+  // In this situation, the map key for Item will be set to "name".+  // TODO: Fully-implement this, then remove the "experimental_" prefix.+  optional string experimental_map_key = 9;+}++message EnumOptions {+}++message EnumValueOptions {+}++message ServiceOptions {++  // Note:  Field numbers 1 through 32 are reserved for Google's internal RPC+  //   framework.  We apologize for hoarding these numbers to ourselves, but+  //   we were already using them long before we decided to release Protocol+  //   Buffers.+}++message MethodOptions {++  // Note:  Field numbers 1 through 32 are reserved for Google's internal RPC+  //   framework.  We apologize for hoarding these numbers to ourselves, but+  //   we were already using them long before we decided to release Protocol+  //   Buffers.+}
doc.txt view
@@ -1,5 +1,46 @@ By Chris Kukelwicz, started 2008-07-08 +---- In Progress++Make Gen.hs generate trivial Get.hs instances for EnumDescriptorProto and DescriptorProtos.+  (will be simply get f m = f m, or get = ($))++I think Gen.hs has all I need for bootstrapping.+Now needed is+  (1) A .proto file parser or lexer/parser that works on descriptor.proto (take old Parsec or new Alex?)+  (2) A name-resolution pass to turn all message & enum references into fully qualified names.+  (3) A mangling pass to make all names valid in haskell+  (4) Ensure the needed fields are set (name/number/label/type, and when relevant, the type_name)++From there the Gen.hs can generate the module text, only an output routine is missing.++At that point the basic system will be bootstrapped.  ++DONE+(*) Create the wire format and generate Wire instances++Then TODO is still quite long+(*) Test Wire instances+(*) continuation based Get+(*) save decomposed reals instead of rationals+(*) Add more support to .proto loading+   (**) extension support+   (**) groups+   (**) service/rpc+(*) Add support to Gen.hs code generation+   (**) Get.hs style API instances+   (**) extension, group, service support+   (**) detect and handle mutually recursive module references+(*) RPC API and instances+++----++wire format: Using Data.Binary.Get/Put/Builder will make this trivial.+  Only ugly piece is Double <-> [Word8] which I have prototyped in WireMessage.hs++----+ I am uploading this to hackage early, in case someone wished to avoid duplicating effort. @@ -76,3 +117,4 @@   If Yes then     => This implies that the type are more complicated and invalid message can be repesented. +"If an invalid enum value is read when parsing a message, it will be treated as an unknown field."
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name:           protocol-buffers-version:        0.0.5+version:        0.1.0 cabal-version:  >= 1.2 build-type:     Simple license:        BSD3@@ -45,14 +45,20 @@                    Text.DescriptorProtos.MethodOptions                    Text.DescriptorProtos.ServiceDescriptorProto                    Text.DescriptorProtos.ServiceOptions+                   Text.ProtocolBuffers.Basic+                   Text.ProtocolBuffers.BootStrap                    Text.ProtocolBuffers.Default+                   Text.ProtocolBuffers.DeriveMergeable+                   Text.ProtocolBuffers.Gen+                   Text.ProtocolBuffers.Get                    Text.ProtocolBuffers.Header                    Text.ProtocolBuffers.Instances-                   Text.ProtocolBuffers.ParseProto-                   Text.ProtocolBuffers.WireMessage+                   Text.ProtocolBuffers.Lexer                    Text.ProtocolBuffers.Mergeable-                   Text.ProtocolBuffers.DeriveMergeable-                   Text.ProtocolBuffers.Gen+                   Text.ProtocolBuffers.Parser+                   Text.ProtocolBuffers.Reflections+                   Text.ProtocolBuffers.Resolve+                   Text.ProtocolBuffers.WireMessage    if flag(small_base)         build-depends: base >= 3,@@ -62,9 +68,14 @@   else         build-depends: base < 3 -  build-depends:   derive, parsec, utf8-string, haskell-src-exts+  build-depends:   binary, binary-strict, derive, parsec, utf8-string, haskell-src-exts   extensions:      GADTs,                    EmptyDataDecls,                    TemplateHaskell,                    DeriveDataTypeable,-                   FlexibleInstances+                   FlexibleInstances,+                   PatternGuards,+                   MagicHash,+                   GeneralizedNewtypeDeriving,+                   ScopedTypeVariables,+                   RankNTypes
+ unittest.proto view
@@ -0,0 +1,452 @@+// Protocol Buffers - Google's data interchange format+// Copyright 2008 Google Inc.+// http://code.google.com/p/protobuf/+//+// Licensed under the Apache License, Version 2.0 (the "License");+// you may not use this file except in compliance with the License.+// You may obtain a copy of the License at+//+//      http://www.apache.org/licenses/LICENSE-2.0+//+// Unless required by applicable law or agreed to in writing, software+// distributed under the License is distributed on an "AS IS" BASIS,+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+// See the License for the specific language governing permissions and+// limitations under the License.++// Author: kenton@google.com (Kenton Varda)+//  Based on original Protocol Buffers design by+//  Sanjay Ghemawat, Jeff Dean, and others.+//+// A proto file we will use for unit testing.+++import "google/protobuf/unittest_import.proto";++// We don't put this in a package within proto2 because we need to make sure+// that the generated code doesn't depend on being in the proto2 namespace.+// In test_util.h we do "using namespace unittest = protobuf_unittest".+package protobuf_unittest;++// Protos optimized for SPEED use a strict superset of the generated code+// of equivalent ones optimized for CODE_SIZE, so we should optimize all our+// tests for speed unless explicitly testing code size optimization.+option optimize_for = SPEED;++option java_outer_classname = "UnittestProto";++// This proto includes every type of field in both singular and repeated+// forms.+message TestAllTypes {+  message NestedMessage {+    // The field name "b" fails to compile in proto1 because it conflicts with+    // a local variable named "b" in one of the generated methods.  Doh.+    // This file needs to compile in proto1 to test backwards-compatibility.+    optional int32 bb = 1;+  }++  enum NestedEnum {+    FOO = 1;+    BAR = 2;+    BAZ = 3;+  }++  // Singular+  optional    int32 optional_int32    =  1;+  optional    int64 optional_int64    =  2;+  optional   uint32 optional_uint32   =  3;+  optional   uint64 optional_uint64   =  4;+  optional   sint32 optional_sint32   =  5;+  optional   sint64 optional_sint64   =  6;+  optional  fixed32 optional_fixed32  =  7;+  optional  fixed64 optional_fixed64  =  8;+  optional sfixed32 optional_sfixed32 =  9;+  optional sfixed64 optional_sfixed64 = 10;+  optional    float optional_float    = 11;+  optional   double optional_double   = 12;+  optional     bool optional_bool     = 13;+  optional   string optional_string   = 14;+  optional    bytes optional_bytes    = 15;++  optional group OptionalGroup = 16 {+    optional int32 a = 17;+  }++  optional NestedMessage                        optional_nested_message  = 18;+  optional ForeignMessage                       optional_foreign_message = 19;+  optional protobuf_unittest_import.ImportMessage optional_import_message  = 20;++  optional NestedEnum                           optional_nested_enum     = 21;+  optional ForeignEnum                          optional_foreign_enum    = 22;+  optional protobuf_unittest_import.ImportEnum    optional_import_enum     = 23;++  optional string optional_string_piece = 24 [ctype=STRING_PIECE];+  optional string optional_cord = 25 [ctype=CORD];++  // Repeated+  repeated    int32 repeated_int32    = 31;+  repeated    int64 repeated_int64    = 32;+  repeated   uint32 repeated_uint32   = 33;+  repeated   uint64 repeated_uint64   = 34;+  repeated   sint32 repeated_sint32   = 35;+  repeated   sint64 repeated_sint64   = 36;+  repeated  fixed32 repeated_fixed32  = 37;+  repeated  fixed64 repeated_fixed64  = 38;+  repeated sfixed32 repeated_sfixed32 = 39;+  repeated sfixed64 repeated_sfixed64 = 40;+  repeated    float repeated_float    = 41;+  repeated   double repeated_double   = 42;+  repeated     bool repeated_bool     = 43;+  repeated   string repeated_string   = 44;+  repeated    bytes repeated_bytes    = 45;++  repeated group RepeatedGroup = 46 {+    optional int32 a = 47;+  }++  repeated NestedMessage                        repeated_nested_message  = 48;+  repeated ForeignMessage                       repeated_foreign_message = 49;+  repeated protobuf_unittest_import.ImportMessage repeated_import_message  = 50;++  repeated NestedEnum                           repeated_nested_enum     = 51;+  repeated ForeignEnum                          repeated_foreign_enum    = 52;+  repeated protobuf_unittest_import.ImportEnum    repeated_import_enum     = 53;++  repeated string repeated_string_piece = 54 [ctype=STRING_PIECE];+  repeated string repeated_cord = 55 [ctype=CORD];++  // Singular with defaults+  optional    int32 default_int32    = 61 [default =  41    ];+  optional    int64 default_int64    = 62 [default =  42    ];+  optional   uint32 default_uint32   = 63 [default =  43    ];+  optional   uint64 default_uint64   = 64 [default =  44    ];+  optional   sint32 default_sint32   = 65 [default = -45    ];+  optional   sint64 default_sint64   = 66 [default =  46    ];+  optional  fixed32 default_fixed32  = 67 [default =  47    ];+  optional  fixed64 default_fixed64  = 68 [default =  48    ];+  optional sfixed32 default_sfixed32 = 69 [default =  49    ];+  optional sfixed64 default_sfixed64 = 70 [default = -50    ];+  optional    float default_float    = 71 [default =  51.5  ];+  optional   double default_double   = 72 [default =  52e3  ];+  optional     bool default_bool     = 73 [default = true   ];+  optional   string default_string   = 74 [default = "hello"];+  optional    bytes default_bytes    = 75 [default = "world"];++  optional NestedEnum  default_nested_enum  = 81 [default = BAR        ];+  optional ForeignEnum default_foreign_enum = 82 [default = FOREIGN_BAR];+  optional protobuf_unittest_import.ImportEnum+      default_import_enum = 83 [default = IMPORT_BAR];++  optional string default_string_piece = 84 [ctype=STRING_PIECE,default="abc"];+  optional string default_cord = 85 [ctype=CORD,default="123"];+}++// Define these after TestAllTypes to make sure the compiler can handle+// that.+message ForeignMessage {+  optional int32 c = 1;+}++enum ForeignEnum {+  FOREIGN_FOO = 4;+  FOREIGN_BAR = 5;+  FOREIGN_BAZ = 6;+}++message TestAllExtensions {+  extensions 1 to max;+}++extend TestAllExtensions {+  // Singular+  optional    int32 optional_int32_extension    =  1;+  optional    int64 optional_int64_extension    =  2;+  optional   uint32 optional_uint32_extension   =  3;+  optional   uint64 optional_uint64_extension   =  4;+  optional   sint32 optional_sint32_extension   =  5;+  optional   sint64 optional_sint64_extension   =  6;+  optional  fixed32 optional_fixed32_extension  =  7;+  optional  fixed64 optional_fixed64_extension  =  8;+  optional sfixed32 optional_sfixed32_extension =  9;+  optional sfixed64 optional_sfixed64_extension = 10;+  optional    float optional_float_extension    = 11;+  optional   double optional_double_extension   = 12;+  optional     bool optional_bool_extension     = 13;+  optional   string optional_string_extension   = 14;+  optional    bytes optional_bytes_extension    = 15;++  optional group OptionalGroup_extension = 16 {+    optional int32 a = 17;+  }++  optional TestAllTypes.NestedMessage optional_nested_message_extension = 18;+  optional ForeignMessage optional_foreign_message_extension = 19;+  optional protobuf_unittest_import.ImportMessage+    optional_import_message_extension = 20;++  optional TestAllTypes.NestedEnum optional_nested_enum_extension = 21;+  optional ForeignEnum optional_foreign_enum_extension = 22;+  optional protobuf_unittest_import.ImportEnum+    optional_import_enum_extension = 23;++  optional string optional_string_piece_extension = 24 [ctype=STRING_PIECE];+  optional string optional_cord_extension = 25 [ctype=CORD];++  // Repeated+  repeated    int32 repeated_int32_extension    = 31;+  repeated    int64 repeated_int64_extension    = 32;+  repeated   uint32 repeated_uint32_extension   = 33;+  repeated   uint64 repeated_uint64_extension   = 34;+  repeated   sint32 repeated_sint32_extension   = 35;+  repeated   sint64 repeated_sint64_extension   = 36;+  repeated  fixed32 repeated_fixed32_extension  = 37;+  repeated  fixed64 repeated_fixed64_extension  = 38;+  repeated sfixed32 repeated_sfixed32_extension = 39;+  repeated sfixed64 repeated_sfixed64_extension = 40;+  repeated    float repeated_float_extension    = 41;+  repeated   double repeated_double_extension   = 42;+  repeated     bool repeated_bool_extension     = 43;+  repeated   string repeated_string_extension   = 44;+  repeated    bytes repeated_bytes_extension    = 45;++  repeated group RepeatedGroup_extension = 46 {+    optional int32 a = 47;+  }++  repeated TestAllTypes.NestedMessage repeated_nested_message_extension = 48;+  repeated ForeignMessage repeated_foreign_message_extension = 49;+  repeated protobuf_unittest_import.ImportMessage+    repeated_import_message_extension = 50;++  repeated TestAllTypes.NestedEnum repeated_nested_enum_extension = 51;+  repeated ForeignEnum repeated_foreign_enum_extension = 52;+  repeated protobuf_unittest_import.ImportEnum+    repeated_import_enum_extension = 53;++  repeated string repeated_string_piece_extension = 54 [ctype=STRING_PIECE];+  repeated string repeated_cord_extension = 55 [ctype=CORD];++  // Singular with defaults+  optional    int32 default_int32_extension    = 61 [default =  41    ];+  optional    int64 default_int64_extension    = 62 [default =  42    ];+  optional   uint32 default_uint32_extension   = 63 [default =  43    ];+  optional   uint64 default_uint64_extension   = 64 [default =  44    ];+  optional   sint32 default_sint32_extension   = 65 [default = -45    ];+  optional   sint64 default_sint64_extension   = 66 [default =  46    ];+  optional  fixed32 default_fixed32_extension  = 67 [default =  47    ];+  optional  fixed64 default_fixed64_extension  = 68 [default =  48    ];+  optional sfixed32 default_sfixed32_extension = 69 [default =  49    ];+  optional sfixed64 default_sfixed64_extension = 70 [default = -50    ];+  optional    float default_float_extension    = 71 [default =  51.5  ];+  optional   double default_double_extension   = 72 [default =  52e3  ];+  optional     bool default_bool_extension     = 73 [default = true   ];+  optional   string default_string_extension   = 74 [default = "hello"];+  optional    bytes default_bytes_extension    = 75 [default = "world"];++  optional TestAllTypes.NestedEnum+    default_nested_enum_extension = 81 [default = BAR];+  optional ForeignEnum+    default_foreign_enum_extension = 82 [default = FOREIGN_BAR];+  optional protobuf_unittest_import.ImportEnum+    default_import_enum_extension = 83 [default = IMPORT_BAR];++  optional string default_string_piece_extension = 84 [ctype=STRING_PIECE,+                                                       default="abc"];+  optional string default_cord_extension = 85 [ctype=CORD, default="123"];+}++// We have separate messages for testing required fields because it's+// annoying to have to fill in required fields in TestProto in order to+// do anything with it.  Note that we don't need to test every type of+// required filed because the code output is basically identical to+// optional fields for all types.+message TestRequired {+  required int32 a = 1;+  optional int32 dummy2 = 2;+  required int32 b = 3;++  extend TestAllExtensions {+    optional TestRequired single = 1000;+    repeated TestRequired multi  = 1001;+  }++  // Pad the field count to 32 so that we can test that IsInitialized()+  // properly checks multiple elements of has_bits_.+  optional int32 dummy4  =  4;+  optional int32 dummy5  =  5;+  optional int32 dummy6  =  6;+  optional int32 dummy7  =  7;+  optional int32 dummy8  =  8;+  optional int32 dummy9  =  9;+  optional int32 dummy10 = 10;+  optional int32 dummy11 = 11;+  optional int32 dummy12 = 12;+  optional int32 dummy13 = 13;+  optional int32 dummy14 = 14;+  optional int32 dummy15 = 15;+  optional int32 dummy16 = 16;+  optional int32 dummy17 = 17;+  optional int32 dummy18 = 18;+  optional int32 dummy19 = 19;+  optional int32 dummy20 = 20;+  optional int32 dummy21 = 21;+  optional int32 dummy22 = 22;+  optional int32 dummy23 = 23;+  optional int32 dummy24 = 24;+  optional int32 dummy25 = 25;+  optional int32 dummy26 = 26;+  optional int32 dummy27 = 27;+  optional int32 dummy28 = 28;+  optional int32 dummy29 = 29;+  optional int32 dummy30 = 30;+  optional int32 dummy31 = 31;+  optional int32 dummy32 = 32;++  required int32 c = 33;+}++message TestRequiredForeign {+  optional TestRequired optional_message = 1;+  repeated TestRequired repeated_message = 2;+  optional int32 dummy = 3;+}++// Test that we can use NestedMessage from outside TestAllTypes.+message TestForeignNested {+  optional TestAllTypes.NestedMessage foreign_nested = 1;+}++// TestEmptyMessage is used to test unknown field support.+message TestEmptyMessage {+}++// Like above, but declare all field numbers as potential extensions.  No+// actual extensions should ever be defined for this type.+message TestEmptyMessageWithExtensions {+  extensions 1 to max;+}++// Test that really large tag numbers don't break anything.+message TestReallyLargeTagNumber {+  // The largest possible tag number is 2^28 - 1, since the wire format uses+  // three bits to communicate wire type.+  optional int32 a = 1;+  optional int32 bb = 268435455;+}++message TestRecursiveMessage {+  optional TestRecursiveMessage a = 1;+  optional int32 i = 2;+}++// Test that mutual recursion works.+message TestMutualRecursionA {+  optional TestMutualRecursionB bb = 1;+}++message TestMutualRecursionB {+  optional TestMutualRecursionA a = 1;+  optional int32 optional_int32 = 2;+}++// Test that groups have disjoint field numbers from their siblings and+// parents.  This is NOT possible in proto1; only proto2.  When outputting+// proto1, the dup fields should be dropped.+message TestDupFieldNumber {+  optional int32 a = 1;+  optional group Foo = 2 { optional int32 a = 1; }+  optional group Bar = 3 { optional int32 a = 1; }+}+++// Needed for a Python test.+message TestNestedMessageHasBits {+  message NestedMessage {+    repeated int32 nestedmessage_repeated_int32 = 1;+    repeated ForeignMessage nestedmessage_repeated_foreignmessage = 2;+  }+  optional NestedMessage optional_nested_message = 1;+}+++// Test an enum that has multiple values with the same number.+enum TestEnumWithDupValue {+  FOO1 = 1;+  BAR1 = 2;+  BAZ = 3;+  FOO2 = 1;+  BAR2 = 2;+}++// Test an enum with large, unordered values.+enum TestSparseEnum {+  SPARSE_A = 123;+  SPARSE_B = 62374;+  SPARSE_C = 12589234;+//  SPARSE_D = -15;+//  SPARSE_E = -53452;+  SPARSE_F = 0;+  SPARSE_G = 2;+}++// Test message with CamelCase field names.  This violates Protocol Buffer+// standard style.+message TestCamelCaseFieldNames {+  optional int32 PrimitiveField = 1;+  optional string StringField = 2;+  optional ForeignEnum EnumField = 3;+  optional ForeignMessage MessageField = 4;+  optional string StringPieceField = 5 [ctype=STRING_PIECE];+  optional string CordField = 6 [ctype=CORD];++  repeated int32 RepeatedPrimitiveField = 7;+  repeated string RepeatedStringField = 8;+  repeated ForeignEnum RepeatedEnumField = 9;+  repeated ForeignMessage RepeatedMessageField = 10;+  repeated string RepeatedStringPieceField = 11 [ctype=STRING_PIECE];+  repeated string RepeatedCordField = 12 [ctype=CORD];+}+++// We list fields out of order, to ensure that we're using field number and not+// field index to determine serialization order.+message TestFieldOrderings {+  optional string my_string = 11;+  extensions 2 to 10;+  optional int64 my_int = 1;+  extensions 12 to 100;+  optional float my_float = 101;+}+++extend TestFieldOrderings {+  optional string my_extension_string = 50;+  optional int32 my_extension_int = 5;+}+++message TestExtremeDefaultValues {+  optional bytes escaped_bytes = 1 [default = "\0\001\a\b\f\n\r\t\v\\\'\"\xfe"];+  optional uint32 large_uint32 = 2 [default = 0xFFFFFFFF];+  optional uint64 large_uint64 = 3 [default = 0xFFFFFFFFFFFFFFFF];+  optional  int32 small_int32  = 4 [default = -0x7FFFFFFF];+  optional  int64 small_int64  = 5 [default = -0x7FFFFFFFFFFFFFFF];++  // The default value here is UTF-8 for "\u1234".  (We could also just type+  // the UTF-8 text directly into this text file rather than escape it, but+  // lots of people use editors that would be confused by this.)+  optional string utf8_string = 6 [default = "\341\210\264"];+}++// Test that RPC services work.+message FooRequest  {}+message FooResponse {}++service TestService {+  rpc Foo(FooRequest) returns (FooResponse);+  rpc Bar(BarRequest) returns (BarResponse);+}+++message BarRequest  {}+message BarResponse {}