packages feed

protocol-buffers 0.0.1 → 0.0.2

raw patch · 27 files changed

+513/−42 lines, 27 filesdep +derive

Dependencies added: derive

Files

doc.txt view
@@ -3,6 +3,13 @@ I am uploading this to hackage early, in case someone wished to avoid duplicating effort. +I am loeading version 0.0.2 with++cd src+ghci -XTemplateHaskell -XEmptyDataDecls -XGADTs -XFlexibleInstances -XDeriveDataTypeable ProtocolBuffers/ParseProto.hs++Which ensure that DescriptorProtos/* all compile and tests the stub-like parsec parser (runs agains the "test" file).+ http://code.google.com/apis/protocolbuffers/docs/overview.html http://code.google.com/p/protobuf/downloads/list http://groups.google.com/group/protobuf@@ -28,3 +35,13 @@ contents of the strings are not part of the '.proto' file, so the generated data structures do not reflect bounds or encodings.  The parser in (3) can be tweaked to use more fine-grained (new)types.++MONOID !++The text at http://code.google.com/apis/protocolbuffers/docs/encoding.html#optional specifies that Messages are Monoids!+And the rule is simple: Take the last value in the case of conflicts, or concatenate if repeated.++Rather than use+"type MyMaybe a = (Data.Monoid.Last (Data.Maybe.Maybe a))"+I have create ProtocolBuffers.Option which uses a phantom type to record whether it is required,+and it has the last-biased mappend semantics.
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name: protocol-buffers-version: 0.0.1+version: 0.0.2 cabal-version: >= 1.2 build-type: Simple license: BSD3@@ -8,8 +8,8 @@ author: Christopher Edward Kuklewicz maintainer: Chris Kuklewicz <protobuf@personal.mightyreason.com> stability: vapor--- homepage: http://hackage.haskell.org/--- package-url: URL+homepage: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/protocol-buffers+package-url: http://darcs.haskell.org/packages/protocol-buffers/ synopsis: Parse Google Protocol Buffer specifications description: Parse http://code.google.com/apis/protocolbuffers/docs/proto.html   and perhaps general haskell code to use them@@ -18,6 +18,7 @@ -- data-files: extra-source-files: Setup.hs                     doc.txt+                    test -- extra-tmp-files:  Library@@ -42,8 +43,12 @@                    DescriptorProtos.MethodOptions                    DescriptorProtos.ServiceDescriptorProto                    DescriptorProtos.ServiceOptions+                   ProtocolBuffers.Default                    ProtocolBuffers.Header---   build-depends:+                   ProtocolBuffers.Option+                   ProtocolBuffers.ParseProto+  build-depends: derive+  extensions: GADTs, EmptyDataDecls, TemplateHaskell, DeriveDataTypeable, FlexibleInstances  -- Executable proto-hs --   main-is:
src/DescriptorProtos.hs view
@@ -1,6 +1,25 @@-module DescriptorProtos.DescriptorProtos() where+module DescriptorProtos+    (DescriptorProtos.DescriptorProto+    ,DescriptorProtos.DescriptorProto.ExtensionRange+    ,DescriptorProtos.EnumDescriptorProto+    ,DescriptorProtos.EnumOptions+    ,DescriptorProtos.EnumValueDescriptorProto+    ,DescriptorProtos.EnumValueOptions+    ,DescriptorProtos.FieldDescriptorProto+    ,DescriptorProtos.FieldDescriptorProto.Label+    ,DescriptorProtos.FieldDescriptorProto.Type+    ,DescriptorProtos.FieldOptions+    ,DescriptorProtos.FieldOptions.CType+    ,DescriptorProtos.FileOptions+    ,DescriptorProtos.FileOptions.OptimizeMode+    ,DescriptorProtos.MessageOptions+    ,DescriptorProtos.MethodDescriptorProto+    ,DescriptorProtos.MethodOptions+    ,DescriptorProtos.ServiceDescriptorProto+    ,DescriptorProtos.ServiceOptions +    ) where -import qualified DescriptorProtos.DescriptorProto as DescriptorProtos(DescriptorProto) +import qualified DescriptorProtos.DescriptorProto as DescriptorProtos(DescriptorProto) import qualified DescriptorProtos.DescriptorProto.ExtensionRange as DescriptorProtos.DescriptorProto(ExtensionRange) import qualified DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto)  import qualified DescriptorProtos.EnumOptions as DescriptorProtos(EnumOptions)
src/DescriptorProtos/DescriptorProto.hs view
@@ -10,11 +10,18 @@ import qualified DescriptorProtos.DescriptorProto.ExtensionRange as DescriptorProtos.DescriptorProto(ExtensionRange)  data DescriptorProto = DescriptorProto-    { name :: Maybe String+    { name :: Optional 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+    , options :: Optional DescriptorProtos.MessageOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''DescriptorProto )++instance OptionFlag a => Monoid (Option a DescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default DescriptorProto where
src/DescriptorProtos/DescriptorProto/ExtensionRange.hs view
@@ -5,6 +5,13 @@ import ProtocolBuffers.Header  data ExtensionRange = ExtensionRange-    { start :: Int32-    , end :: Int32+    { start :: Optional Int32+    , end :: Optional Int32     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''ExtensionRange )++instance OptionFlag a => Monoid (Option a ExtensionRange) where mempty = Absent; mappend = op'Merge++instance Default ExtensionRange where
src/DescriptorProtos/EnumDescriptorProto.hs view
@@ -8,7 +8,14 @@ import qualified DescriptorProtos.EnumOptions as DescriptorProtos(EnumOptions)  data EnumDescriptorProto = EnumDescriptorProto-    { name :: Maybe String+    { name :: Optional ByteString     , value :: Seq DescriptorProtos.EnumValueDescriptorProto-    , options :: Maybe DescriptorProtos.EnumOptions+    , options :: Optional DescriptorProtos.EnumOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''EnumDescriptorProto )++instance OptionFlag a => Monoid (Option a EnumDescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default EnumDescriptorProto where
src/DescriptorProtos/EnumOptions.hs view
@@ -5,3 +5,10 @@ import ProtocolBuffers.Header  data EnumOptions = EnumOptions+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''EnumOptions )++instance OptionFlag a => Monoid (Option a EnumOptions) where mempty = Absent; mappend = op'Merge++instance Default EnumOptions where
src/DescriptorProtos/EnumValueDescriptorProto.hs view
@@ -6,7 +6,14 @@ import qualified DescriptorProtos.EnumValueOptions as DescriptorProtos(EnumValueOptions)   data EnumValueDescriptorProto = EnumValueDescriptorProto-    { name :: Maybe String-    , number :: Maybe Int32-    , options :: Maybe DescriptorProtos.EnumValueOptions+    { name :: Optional ByteString+    , number :: Optional Int32+    , options :: Optional DescriptorProtos.EnumValueOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''EnumValueDescriptorProto )++instance OptionFlag a => Monoid (Option a EnumValueDescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default EnumValueDescriptorProto where
src/DescriptorProtos/EnumValueOptions.hs view
@@ -5,3 +5,10 @@ import ProtocolBuffers.Header  data EnumValueOptions = EnumValueOptions+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''EnumValueOptions )++instance OptionFlag a => Monoid (Option a EnumValueOptions) where mempty = Absent; mappend = op'Merge++instance Default EnumValueOptions where
src/DescriptorProtos/FieldDescriptorProto.hs view
@@ -8,12 +8,19 @@ import qualified DescriptorProtos.FieldOptions as DescriptorProtos(FieldOptions)  data FieldDescriptorProto = FieldDescriptorProto-    { name :: Maybe String-    , number :: Maybe Int32-    , labelEnum :: Maybe DescriptorProtos.FieldDescriptorProto.Label-    , typeEnum :: Maybe DescriptorProtos.FieldDescriptorProto.Type-    , type_name :: Maybe String-    , extendee :: Maybe String-    , default_value :: Maybe String-    , options :: Maybe DescriptorProtos.FieldOptions+    { name :: Optional ByteString+    , number :: Optional Int32+    , labelEnum :: Optional DescriptorProtos.FieldDescriptorProto.Label+    , typeEnum :: Optional DescriptorProtos.FieldDescriptorProto.Type+    , type_name :: Optional ByteString+    , extendee :: Optional ByteString+    , default_value :: Optional ByteString+    , options :: Optional DescriptorProtos.FieldOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''FieldDescriptorProto )++instance OptionFlag a => Monoid (Option a FieldDescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default FieldDescriptorProto where
src/DescriptorProtos/FieldDescriptorProto/Label.hs view
@@ -7,6 +7,10 @@ data Label = LABEL_OPTIONAL            | LABEL_REQUIRED            | LABEL_REPEATED-  deriving (Show,Eq,Ord,Typeable,Data)+  deriving (Show,Eq,Ord,Typeable)++instance OptionFlag a => Monoid (Option a Label) where+  mempty = Absent+  mappend = flip const
src/DescriptorProtos/FieldDescriptorProto/Type.hs view
@@ -23,3 +23,8 @@           | TYPE_SFIXED64           | TYPE_SINT32 -- Uses ZipZag encoding           | TYPE_SINT64 -- Uses ZipZag encoding+  deriving (Show,Eq,Ord,Typeable)++instance OptionFlag a => Monoid (Option a Type) where+  mempty = Absent+  mappend = flip const
src/DescriptorProtos/FieldOptions.hs view
@@ -7,6 +7,14 @@ import qualified DescriptorProtos.FieldOptions.CType as DescriptorProtos.FieldOptions(CType)  data FieldOptions = FieldOptions-    { ctype :: Maybe DescriptorProtos.FieldOptions.CType-    , experimental_map_key :: Maybe String+    { ctype :: Optional DescriptorProtos.FieldOptions.CType+    , experimental_map_key :: Optional ByteString     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''FieldOptions )++instance OptionFlag a => Monoid (Option a FieldOptions) where mempty = Absent; mappend = op'Merge++instance Default FieldOptions where+
src/DescriptorProtos/FieldOptions/CType.hs view
@@ -5,3 +5,9 @@ import ProtocolBuffers.Header  data CType = CORD | STRING_PIECE+  deriving (Show,Eq,Ord,Typeable)++instance OptionFlag a => Monoid (Option a CType) where+  mempty = Absent+  mappend = op'Last+
src/DescriptorProtos/FileDescriptorProto.hs view
@@ -10,12 +10,19 @@ import qualified DescriptorProtos.ServiceDescriptorProto as DescriptorProtos(ServiceDescriptorProto)   data FileDescriptorProto = FileDescriptorProto-    { name :: Maybe String-    , package :: Maybe String-    , dependency :: Seq String+    { name :: Optional ByteString+    , package :: Optional 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+    , options :: Optional DescriptorProtos.FileOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''FileDescriptorProto )++instance OptionFlag a => Monoid (Option a FileDescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default FileDescriptorProto where
src/DescriptorProtos/FileOptions.hs view
@@ -4,10 +4,22 @@  import ProtocolBuffers.Header import qualified DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions(OptimizeMode)+import qualified DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions.OptimizeMode(OptimizeMode(..))  data FileOptions = FileOptions-    { java_package :: Maybe String-    , java_outer_classname :: Maybe String-    , java_multiple_files :: Maybe Bool-    , optimize_for :: Maybe DescriptorProtos.FileOptions.OptimizeMode+    { java_package :: Optional ByteString+    , java_outer_classname :: Optional ByteString+    , java_multiple_files :: Optional Bool+    , optimize_for :: Optional DescriptorProtos.FileOptions.OptimizeMode+    }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''FileOptions )++instance OptionFlag a => Monoid (Option a FileOptions) where mempty = Absent; mappend = op'Merge++instance Default FileOptions where+  defaultValue = mempty+    { java_multiple_files = Present False+    , optimize_for = Present DescriptorProtos.FileOptions.OptimizeMode.CODE_SIZE     }
src/DescriptorProtos/FileOptions/OptimizeMode.hs view
@@ -2,9 +2,30 @@   (OptimizeMode(..))  where +import Data.Monoid import ProtocolBuffers.Header  data OptimizeMode = SPEED | CODE_SIZE   deriving (Show,Eq,Ord,Typeable) +instance OptionFlag a => Monoid (Option a OptimizeMode) where mempty = Absent; mappend = op'Last +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
src/DescriptorProtos/MessageOptions.hs view
@@ -5,5 +5,15 @@ import ProtocolBuffers.Header  data MessageOptions = MessageOptions-    { message_set_wire_format :: Maybe Bool+    { message_set_wire_format :: Optional Bool+    }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''MessageOptions )++instance OptionFlag a => Monoid (Option a MessageOptions) where mempty = Absent; mappend = op'Merge++instance Default MessageOptions where+  defaultValue = mempty+    { message_set_wire_format = Present False     }
src/DescriptorProtos/MethodDescriptorProto.hs view
@@ -6,8 +6,15 @@ import qualified DescriptorProtos.MethodOptions as DescriptorProtos(MethodOptions)  data MethodDescriptorProto = MethodDescriptorProto-    { name :: Maybe String-    , input_type :: Maybe String-    , output_type :: Maybe String-    , options :: Maybe DescriptorProtos.MethodOptions+    { name :: Optional ByteString+    , input_type :: Optional ByteString+    , output_type :: Optional ByteString+    , options :: Optional DescriptorProtos.MethodOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''MethodDescriptorProto )++instance OptionFlag a => Monoid (Option a MethodDescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default MethodDescriptorProto where
src/DescriptorProtos/MethodOptions.hs view
@@ -5,3 +5,10 @@ import ProtocolBuffers.Header  data MethodOptions = MethodOptions+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''MethodOptions )++instance OptionFlag a => Monoid (Option a MethodOptions) where mempty = Absent; mappend = op'Merge++instance Default MethodOptions where
src/DescriptorProtos/ServiceDescriptorProto.hs view
@@ -8,7 +8,14 @@ import qualified DescriptorProtos.ServiceOptions as DescriptorProtos(ServiceOptions)  data ServiceDescriptorProto = ServiceDescriptorProto-    { name :: Maybe String+    { name :: Optional ByteString     , method :: Seq DescriptorProtos.MethodDescriptorProto-    , options :: Maybe DescriptorProtos.ServiceOptions+    , options :: Optional DescriptorProtos.ServiceOptions     }+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''ServiceDescriptorProto )++instance OptionFlag a => Monoid (Option a ServiceDescriptorProto) where mempty = Absent; mappend = op'Merge++instance Default ServiceDescriptorProto where
src/DescriptorProtos/ServiceOptions.hs view
@@ -5,3 +5,10 @@ import ProtocolBuffers.Header  data ServiceOptions = ServiceOptions+  deriving (Show,Eq,Ord,Typeable)++$( derive makeMonoid ''ServiceOptions )++instance OptionFlag a => Monoid (Option a ServiceOptions) where mempty = Absent; mappend = op'Merge++instance Default ServiceOptions where
+ src/ProtocolBuffers/Default.hs view
@@ -0,0 +1,7 @@+module ProtocolBuffers.Default(Default(..)) where++import Data.Monoid++class Monoid a => Default a where+  defaultValue :: a+  defaultValue = mempty
src/ProtocolBuffers/Header.hs view
@@ -1,9 +1,24 @@-module ProtocolBuffers.Header (UArray,ByteString,Data(..),Int32,Int64,Seq,Typeable(..),Word32,Word64) where+module ProtocolBuffers.Header (UArray,ByteString,Data(..),Int32,Int64,Seq,Typeable(..),Word32,Word64+                              ,module ProtocolBuffers.Option,module ProtocolBuffers.Default+                              ,module Data.Monoid,module Data.DeriveTH,module Data.Derive.Monoid) where  import Data.Array.Unboxed(UArray) import Data.ByteString(ByteString)+import Data.Derive.Monoid+import Data.DeriveTH 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 ProtocolBuffers.Option+import ProtocolBuffers.Default++--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
+ src/ProtocolBuffers/Option.hs view
@@ -0,0 +1,47 @@+module 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
+ src/ProtocolBuffers/ParseProto.hs view
@@ -0,0 +1,195 @@+module ProtocolBuffers.ParseProto where++-- see compiler/parser.cc in the google source code++import qualified DescriptorProtos.DescriptorProto                as D(DescriptorProto)+import qualified DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))+import qualified DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto(ExtensionRange)+import qualified DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto.ExtensionRange(ExtensionRange(..))+import qualified DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto) +import qualified DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..)) +import qualified DescriptorProtos.EnumOptions                    as D(EnumOptions)+import qualified DescriptorProtos.EnumOptions                    as D.EnumOptions(EnumOptions(..))+import qualified DescriptorProtos.EnumValueDescriptorProto       as D(EnumValueDescriptorProto)+import qualified DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))+import qualified DescriptorProtos.EnumValueOptions               as D(EnumValueOptions) +import qualified DescriptorProtos.EnumValueOptions               as D.EnumValueOptions(EnumValueOptions(..)) +import qualified DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto) +import qualified DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..)) +import qualified DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto(Label)+import qualified DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto.Label(Label(..))+import qualified DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type)+import qualified DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto.Type(Type(..))+import qualified DescriptorProtos.FieldOptions                   as D(FieldOptions)+import qualified DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))+import qualified DescriptorProtos.FieldOptions.CType             as D.FieldOptions(CType)+import qualified DescriptorProtos.FieldOptions.CType             as D.FieldOptions.CType(CType(..))+import qualified DescriptorProtos.FileOptions                    as D(FileOptions)+import qualified DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto) +import qualified DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..)) +import qualified DescriptorProtos.FileOptions                    as D.FileOptions(FileOptions(..))+import qualified DescriptorProtos.FileOptions.OptimizeMode       as D.FileOptions(OptimizeMode)+import qualified DescriptorProtos.FileOptions.OptimizeMode       as D.FileOptions.OptimizeMode(OptimizeMode(..))+import qualified DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto)+import qualified DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..))+import qualified DescriptorProtos.MessageOptions                 as D(MessageOptions)+import qualified DescriptorProtos.MessageOptions                 as D.MessageOptions(MessageOptions(..))+import qualified DescriptorProtos.MethodOptions                  as D(MethodOptions)+import qualified DescriptorProtos.MethodOptions                  as D.MethodOptions(MethodOptions(..))+import qualified DescriptorProtos.ServiceDescriptorProto         as D(ServiceDescriptorProto) +import qualified DescriptorProtos.ServiceDescriptorProto         as D.ServiceDescriptorProto(ServiceDescriptorProto(..)) +import qualified DescriptorProtos.ServiceOptions                 as D(ServiceOptions)+import qualified DescriptorProtos.ServiceOptions                 as D.ServiceOptions(ServiceOptions(..))++import ProtocolBuffers.Header+import ProtocolBuffers.Instances+import ProtocolBuffers.Option++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 :: OptionFlag a => String -> [b] -> (Option a b,Maybe String)+unique e [] = (Absent,Nothing)+unique e [b] = (Present b,Nothing)+unique e bs = (Present (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      = mconcat [ Present 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      = mconcat [ Present 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 = Present (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 = Present bs })+   optionByName "java_outer_classname" = do+     bs <- parseString+     return (defaultValue { D.FileOptions.java_outer_classname = Present bs })+   optionByName "java_multiple_files" = do+     bool <- parseBool+     return (defaultValue { D.FileOptions.java_multiple_files = Present bool })+   optionByName "optimize_for" = do+     mode <- parseOptimizeMode+     return (defaultValue { D.FileOptions.optimize_for = Present 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"+
+ test view
@@ -0,0 +1,16 @@+//I START WITH A COMMENT++// Currently keeps the LAST package statement+package i.will.be.ignored;+package i.will.be.kept;++// Not quite ready yet+// option java_outer_classname = "Super.Proto.First";+// option java_outer_classname = 'Super.Proto.Middle';+// option java_outer_classname = "Super.Proto.Last";++ ; // Extra semicolon++message Whee++ ;  ; message Whoops;