diff --git a/Text/DescriptorProtos.hs b/Text/DescriptorProtos.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos.hs @@ -0,0 +1,39 @@ +module Text.DescriptorProtos + (Text.DescriptorProtos.DescriptorProto + ,Text.DescriptorProtos.DescriptorProto.ExtensionRange + ,Text.DescriptorProtos.EnumDescriptorProto + ,Text.DescriptorProtos.EnumOptions + ,Text.DescriptorProtos.EnumValueDescriptorProto + ,Text.DescriptorProtos.EnumValueOptions + ,Text.DescriptorProtos.FieldDescriptorProto + ,Text.DescriptorProtos.FieldDescriptorProto.Label + ,Text.DescriptorProtos.FieldDescriptorProto.Type + ,Text.DescriptorProtos.FieldOptions + ,Text.DescriptorProtos.FieldOptions.CType + ,Text.DescriptorProtos.FileOptions + ,Text.DescriptorProtos.FileOptions.OptimizeMode + ,Text.DescriptorProtos.MessageOptions + ,Text.DescriptorProtos.MethodDescriptorProto + ,Text.DescriptorProtos.MethodOptions + ,Text.DescriptorProtos.ServiceDescriptorProto + ,Text.DescriptorProtos.ServiceOptions + ) where + +import qualified Text.DescriptorProtos.DescriptorProto as Text.DescriptorProtos(DescriptorProto) +import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as Text.DescriptorProtos.DescriptorProto(ExtensionRange) +import qualified Text.DescriptorProtos.EnumDescriptorProto as Text.DescriptorProtos(EnumDescriptorProto) +import qualified Text.DescriptorProtos.EnumOptions as Text.DescriptorProtos(EnumOptions) +import qualified Text.DescriptorProtos.EnumValueDescriptorProto as Text.DescriptorProtos(EnumValueDescriptorProto) +import qualified Text.DescriptorProtos.EnumValueOptions as Text.DescriptorProtos(EnumValueOptions) +import qualified Text.DescriptorProtos.FieldDescriptorProto as Text.DescriptorProtos(FieldDescriptorProto) +import qualified Text.DescriptorProtos.FieldDescriptorProto.Label as Text.DescriptorProtos.FieldDescriptorProto(Label) +import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as Text.DescriptorProtos.FieldDescriptorProto(Type) +import qualified Text.DescriptorProtos.FieldOptions as Text.DescriptorProtos(FieldOptions) +import qualified Text.DescriptorProtos.FieldOptions.CType as Text.DescriptorProtos.FieldOptions(CType) +import qualified Text.DescriptorProtos.FileOptions as Text.DescriptorProtos(FileOptions) +import qualified Text.DescriptorProtos.FileOptions.OptimizeMode as Text.DescriptorProtos.FileOptions(OptimizeMode) +import qualified Text.DescriptorProtos.MessageOptions as Text.DescriptorProtos(MessageOptions) +import qualified Text.DescriptorProtos.MethodDescriptorProto as Text.DescriptorProtos(MethodDescriptorProto) +import qualified Text.DescriptorProtos.MethodOptions as Text.DescriptorProtos(MethodOptions) +import qualified Text.DescriptorProtos.ServiceDescriptorProto as Text.DescriptorProtos(ServiceDescriptorProto) +import qualified Text.DescriptorProtos.ServiceOptions as Text.DescriptorProtos(ServiceOptions) diff --git a/Text/DescriptorProtos/DescriptorProto.hs b/Text/DescriptorProtos/DescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/DescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/DescriptorProto/ExtensionRange.hs b/Text/DescriptorProtos/DescriptorProto/ExtensionRange.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/DescriptorProto/ExtensionRange.hs @@ -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 diff --git a/Text/DescriptorProtos/EnumDescriptorProto.hs b/Text/DescriptorProtos/EnumDescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/EnumDescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/EnumOptions.hs b/Text/DescriptorProtos/EnumOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/EnumOptions.hs @@ -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 diff --git a/Text/DescriptorProtos/EnumValueDescriptorProto.hs b/Text/DescriptorProtos/EnumValueDescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/EnumValueDescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/EnumValueOptions.hs b/Text/DescriptorProtos/EnumValueOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/EnumValueOptions.hs @@ -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 diff --git a/Text/DescriptorProtos/FieldDescriptorProto.hs b/Text/DescriptorProtos/FieldDescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FieldDescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/FieldDescriptorProto/Label.hs b/Text/DescriptorProtos/FieldDescriptorProto/Label.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FieldDescriptorProto/Label.hs @@ -0,0 +1,12 @@ +module Text.DescriptorProtos.FieldDescriptorProto.Label + (Label(..)) + where + +import Text.ProtocolBuffers.Header + +data Label = LABEL_OPTIONAL + | LABEL_REQUIRED + | LABEL_REPEATED + deriving (Show,Eq,Ord,Typeable) + +$( makeMergeableEnum ''Label ) diff --git a/Text/DescriptorProtos/FieldDescriptorProto/Type.hs b/Text/DescriptorProtos/FieldDescriptorProto/Type.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FieldDescriptorProto/Type.hs @@ -0,0 +1,28 @@ +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,Eq,Ord,Typeable) + +$( makeMergeableEnum ''Type ) diff --git a/Text/DescriptorProtos/FieldOptions.hs b/Text/DescriptorProtos/FieldOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FieldOptions.hs @@ -0,0 +1,18 @@ +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 + diff --git a/Text/DescriptorProtos/FieldOptions/CType.hs b/Text/DescriptorProtos/FieldOptions/CType.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FieldOptions/CType.hs @@ -0,0 +1,11 @@ +module Text.DescriptorProtos.FieldOptions.CType + (CType(..)) + where + +import Text.ProtocolBuffers.Header + +data CType = CORD | STRING_PIECE + deriving (Show,Eq,Ord,Typeable) + +$( makeMergeableEnum ''CType ) + diff --git a/Text/DescriptorProtos/FileDescriptorProto.hs b/Text/DescriptorProtos/FileDescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FileDescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/FileOptions.hs b/Text/DescriptorProtos/FileOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FileOptions.hs @@ -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 + } diff --git a/Text/DescriptorProtos/FileOptions/OptimizeMode.hs b/Text/DescriptorProtos/FileOptions/OptimizeMode.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/FileOptions/OptimizeMode.hs @@ -0,0 +1,31 @@ +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 diff --git a/Text/DescriptorProtos/MessageOptions.hs b/Text/DescriptorProtos/MessageOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/MessageOptions.hs @@ -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 + } diff --git a/Text/DescriptorProtos/MethodDescriptorProto.hs b/Text/DescriptorProtos/MethodDescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/MethodDescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/MethodOptions.hs b/Text/DescriptorProtos/MethodOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/MethodOptions.hs @@ -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 diff --git a/Text/DescriptorProtos/ServiceDescriptorProto.hs b/Text/DescriptorProtos/ServiceDescriptorProto.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/ServiceDescriptorProto.hs @@ -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 diff --git a/Text/DescriptorProtos/ServiceOptions.hs b/Text/DescriptorProtos/ServiceOptions.hs new file mode 100644 --- /dev/null +++ b/Text/DescriptorProtos/ServiceOptions.hs @@ -0,0 +1,12 @@ +module Text.DescriptorProtos.ServiceOptions + (ServiceOptions(..)) + where + +import Text.ProtocolBuffers.Header + +data ServiceOptions = ServiceOptions + deriving (Show,Eq,Ord,Typeable) + +$( makeMergeable ''ServiceOptions ) + +instance Default ServiceOptions where diff --git a/Text/ProtocolBuffers/Default.hs b/Text/ProtocolBuffers/Default.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Default.hs @@ -0,0 +1,7 @@ +module Text.ProtocolBuffers.Default(Default(..)) where + +import Text.ProtocolBuffers.Mergeable + +class Mergeable a => Default a where + defaultValue :: a + defaultValue = mergeEmpty diff --git a/Text/ProtocolBuffers/DeriveMergeable.hs b/Text/ProtocolBuffers/DeriveMergeable.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/DeriveMergeable.hs @@ -0,0 +1,90 @@ +-- | Derives an instance of @Monoid@. This derivation is limited to +-- data types with only one constructor; it uses the product +-- construction of monoids. +module Text.ProtocolBuffers.DeriveMergeable(makeMergeable,makeMergeableEnum) where + +import Text.ProtocolBuffers.Mergeable +import Language.Haskell.TH.All + +import Control.Monad(liftM2) +import Data.Generics +import Data.DeriveTH + +data Foo +instance Mergeable Foo where + +example = (,) "Mergeable" [d| + instance Mergeable (Maybe Foo) where + mergeEmpty = Nothing + mergeAppend = mayMerge + |] + + +makeMergeable t = liftM2 (++) (derive makeMergeable1 t) (derive makeMergeable2 t) + +makeMergeableEnum t = liftM2 (++) (derive makeMergeable1Enum t) (derive makeMergeable2Enum t) + +makeMergeable1 :: Derivation +makeMergeable1 = derivation mergeable1' "Mergeable" + +mergeable1' dat | length (dataCtors dat) == 1 + = [instance_default "Mergeable" dat [funN "mergeEmpty" [empty],funN "mergeAppend" [append]]] + where + ctor = head $ dataCtors dat + + empty = sclause [] $ lK (ctorName ctor) (replicate (ctorArity ctor) (l0 "mergeEmpty")) + append = sclause [ctp ctor 'x',ctp ctor 'y'] $ + 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 +mergeable2' dat = [InstanceD [] + (AppT (ConT (mkName "Mergeable")) + (AppT (ConT (mkName "Maybe")) + (ConT (mkName foo)))) + [(ValD (VarP (mkName "mergeEmpty")) + (NormalB (ConE (mkName "Nothing"))) []) + ,(ValD (VarP (mkName "mergeAppend")) + (NormalB (VarE (mkName "mayMerge"))) [])]] + where foo = dataName dat + + +makeMergeable1Enum :: Derivation +makeMergeable1Enum = derivation mergeable1Enum' "Mergeable1Enum" +-- instance Mergeable (Maybe a) where +mergeable1Enum' dat = [InstanceD [] + (AppT (ConT (mkName "Mergeable")) + (ConT (mkName foo))) + []] + where foo = dataName dat + +makeMergeable2Enum :: Derivation +makeMergeable2Enum = derivation mergeable2Enum' "Mergeable2Enum" +-- instance Mergeable (Maybe a) where +mergeable2Enum' dat = [InstanceD [] + (AppT (ConT (mkName "Mergeable")) + (AppT (ConT (mkName "Maybe")) + (ConT (mkName foo)))) + [(ValD (VarP (mkName "mergeEmpty")) + (NormalB (ConE (mkName "Nothing"))) []) + ,(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")) + (ConT (mkName foo)))]])) + (head [(AppT (ConT (mkName "Mergeable")) + (AppT (ConT (mkName "Maybe")) + (ConT (mkName foo))))]) + [(ValD (VarP (mkName "mergeEmpty")) + (NormalB (ConE (mkName "Nothing"))) []) + ,(ValD (VarP (mkName "mergeAppend")) + (NormalB (VarE (mkName "mayMerge"))) [])]] + where foo = dataName dat + +-} diff --git a/Text/ProtocolBuffers/Gen.hs b/Text/ProtocolBuffers/Gen.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Gen.hs @@ -0,0 +1,164 @@ +-- Turn *Proto into Language.Haskell.Exts.Syntax from haskell-src-exts package +module Text.ProtocolBuffers.Gen 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.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 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(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 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 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) + +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 +-} + +{- ***************************************************************************************** -} +-- 'descriptorX' renders a DescriptorProto to a data declaration. +-- 'fieldX' renders a FieldDescriptorProto to an entry in a data declaration. +{- ***************************************************************************************** -} + +src :: SrcLoc +src = error "No SrcLoc" + +ident :: ByteString -> HsName +ident bs = HsIdent (U.toString bs) + +typeApp :: String -> HsType -> HsType +typeApp s = HsTyApp (HsTyCon (UnQual (HsIdent 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 + +qmodname :: ByteString -> ByteString -> HsQName +qmodname modName typeName = Qual (Module (U.toString modName)) (ident typeName) + +-- data HsConDecl = HsConDecl HsName [HsBangType] -- ^ ordinary data constructor +-- | HsRecDecl HsName [([HsName],HsBangType)] -- ^ record constructor +fieldX :: D.FieldDescriptorProto -> ([HsName],HsBangType) +fieldX (D.FieldDescriptorProto.FieldDescriptorProto + { D.FieldDescriptorProto.name = Just name + , D.FieldDescriptorProto.label = Just labelEnum + , D.FieldDescriptorProto.type' = type' + , D.FieldDescriptorProto.type_name = type_name + }) + = ([ident name],HsUnBangedTy (labeled (HsTyCon typed))) + where labeled = case labelEnum of + LABEL_OPTIONAL -> typeApp "Maybe" + LABEL_REPEATED -> typeApp "Seq" + LABEL_REQUIRED -> id + typed,typedByName :: HsQName + typed = maybe typedByName typePrimitive type' + typedByName = maybe (error "No Name for Type!") qual type_name + typePrimitive :: Type -> HsQName + typePrimitive = maybe typedByName (UnQual . HsIdent) . useType + +-- HsDataDecl SrcLoc DataOrNew HsContext HsName [HsName] [HsQualConDecl] [HsQName] +-- data HsQualConDecl = HsQualConDecl SrcLoc {-forall-} [HsTyVarBind] {- . -} HsContext {- => -} HsConDecl +-- data HsConDecl = HsConDecl HsName [HsBangType] -- ^ ordinary data constructor +-- | HsRecDecl HsName [([HsName],HsBangType)] -- ^ record constructor +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) + where fields = F.foldr ((:) . fieldX) [] field + +derives :: [HsQName] +derives = map (UnQual . HsIdent) ["Show","Eq","Ord","Data","Typeable"] + +useType :: Type -> Maybe String +useType TYPE_DOUBLE = Just "Double" +useType TYPE_FLOAT = Just "Float" +useType TYPE_BOOL = Just "Bool" +useType TYPE_STRING = Just "ByteString" +useType TYPE_BYTES = Just "ByteString" +useType TYPE_UINT32 = Just "Word32" +useType TYPE_FIXED32 = Just "Word32" +useType TYPE_UINT64 = Just "Word64" +useType TYPE_FIXED64 = Just "Word64" +useType TYPE_INT32 = Just "Int32" +useType TYPE_SINT32 = Just "Int32" +useType TYPE_SFIXED32 = Just "Int32" +useType TYPE_INT64 = Just "Int64" +useType TYPE_SINT64 = Just "Int64" +useType TYPE_SFIXED64 = Just "Int64" +useType TYPE_MESSAGE = Nothing +useType TYPE_ENUM = Nothing +useType TYPE_GROUP = error "" diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Header.hs @@ -0,0 +1,38 @@ +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 + +import Data.Array.Unboxed(UArray) +import Data.ByteString(ByteString) +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 Text.ProtocolBuffers.Default +import Text.ProtocolBuffers.DeriveMergeable +import Text.ProtocolBuffers.Mergeable + +{- +--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 +-} diff --git a/Text/ProtocolBuffers/Instances.hs b/Text/ProtocolBuffers/Instances.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Instances.hs @@ -0,0 +1,60 @@ +module Text.ProtocolBuffers.Instances(showsType,parseType) where + +import Text.ParserCombinators.ReadP +import Text.DescriptorProtos.FieldDescriptorProto.Type(Type(..)) + +{- +instance Show Type where + showsPrec _ = showsType + +instance Read Type where + readsPrec _ = readP_to_S readType +-} + +showsType :: Type -> ShowS +showsType TYPE_DOUBLE s = "double" ++ s +showsType TYPE_FLOAT s = "float" ++ s +showsType TYPE_INT64 s = "int64" ++ s +showsType TYPE_UINT64 s = "uint64" ++ s +showsType TYPE_INT32 s = "int32" ++ s +showsType TYPE_FIXED64 s = "fixed64" ++ s +showsType TYPE_FIXED32 s = "fixed32" ++ s +showsType TYPE_BOOL s = "bool" ++ s +showsType TYPE_STRING s = "string" ++ s +showsType TYPE_GROUP s = "group" ++ s +showsType TYPE_MESSAGE s = "message" ++ s +showsType TYPE_BYTES s = "bytes" ++ s +showsType TYPE_UINT32 s = "uint32" ++ s +showsType TYPE_ENUM s = "enum" ++ s +showsType TYPE_SFIXED32 s = "sfixed32" ++ s +showsType TYPE_SFIXED64 s = "sfixed64" ++ s +showsType TYPE_SINT32 s = "sint32" ++ s +showsType TYPE_SINT64 s = "sint64" ++ s + +parseType :: String -> Maybe Type +parseType s = case readP_to_S readType s of + [(val,[])] -> Just val + _ -> Nothing + +readType :: ReadP Type +readType = choice [ return TYPE_DOUBLE << string "double" + , return TYPE_FLOAT << string "float" + , return TYPE_INT64 << string "int64" + , return TYPE_UINT64 << string "uint64" + , return TYPE_INT32 << string "int32" + , return TYPE_FIXED64 << string "fixed64" + , return TYPE_FIXED32 << string "fixed32" + , return TYPE_BOOL << string "bool" + , return TYPE_STRING << string "string" + , return TYPE_GROUP << string "group" + , return TYPE_MESSAGE << string "message" + , return TYPE_BYTES << string "bytes" + , return TYPE_UINT32 << string "uint32" + , return TYPE_ENUM << string "enum" + , return TYPE_SFIXED32 << string "sfixed32" + , return TYPE_SFIXED64 << string "sfixed64" + , return TYPE_SINT32 << string "sint32" + , return TYPE_SINT64 << string "sint64" + ] + where (<<) = flip (>>) + diff --git a/Text/ProtocolBuffers/Mergeable.hs b/Text/ProtocolBuffers/Mergeable.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Mergeable.hs @@ -0,0 +1,44 @@ +-- 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 + +import Data.ByteString(ByteString) +import Data.Sequence(Seq) +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!" + mergeAppend :: a -> a -> a + mergeAppend a b = b + mergeConcat :: [a] -> a + mergeConcat = 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 (Seq a) where mergeEmpty = mempty; mergeAppend = mappend + +{-# INLINE mayMerge #-} +mayMerge :: (Mergeable b) => Maybe b -> Maybe b -> Maybe b +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 diff --git a/Text/ProtocolBuffers/ParseProto.hs b/Text/ProtocolBuffers/ParseProto.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/ParseProto.hs @@ -0,0 +1,194 @@ +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" + diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -0,0 +1,66 @@ +module Text.ProtocolBuffers.WireMessage where + +import Data.Map + +{- The point of this module: + +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. + +Encoding and Deconding WireMessage does not respect ordering between +different FieldId but must respect ordering of repeated FieldId +values. + +Converting WireData to and from the actual types (e.g. sint64) will be +done elsewhere. + +Converting a WireData to a message type will require code generation +of a class instance. + +-} + +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) + +newtype WireId = WireId { getWireID :: Word32 } -- really 3 bits + deriving (Eq,Ord,Show,Data,Typeable) + +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) + | VarString ByteString -- length of contents as a VarInt + ByteString -- the contents on the wire + deriving (Eq,Ord,Show,Data,Typeable) + +newtype WireMessage = WireMessage (Map FieldId (Seq WireData)) + +instance Monoid WireMessage where + 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 + +composeFieldWire :: FieldId -> WireId -> Word32 +composeFieldWire (FieldId f) (WireId w) = (f `shiftL` 3) .|. w + +decomposeFieldWire :: Word32 -> (FieldId,WireId) +decomposeFieldWire x = (FieldId (x `shiftR` 3), WireId (x .&. 7)) + +encodeWireMessage :: WireMessage -> ByteString +encodeWireMessage = undefined + +decodeWireMessage :: ByteString -> WireMessage +decodeWireMessage = undefined + diff --git a/doc.txt b/doc.txt --- a/doc.txt +++ b/doc.txt @@ -45,3 +45,34 @@ "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. + +Design issues for generated Haskell code: + + * Wire protocol reading + http://code.google.com/apis/protocolbuffers/docs/encoding.html + + The wire protocol decodes a fixed length buffer into a Message. + + The wire protocol reader can break the input into a top level series of (field#,wireType#,data#) + field# is the 29 bit: 0 to 2^29-1 field # + wireType# is 3 bit value (currently Varint, 64-Bit, string, endian 32-Bit) + data# is decoded to some (Varint, Word64, ByteString, Word32) + + see src/ProtocolBuffers/WireMessage.hs for an intermediate repesentation in Haskell + + * Generating Haskell data types + + The parsing result may have unknown fields which will need to be stored somewhere. + These come of the Wire, and can only be stored as a left over ProtocolBuffers.WireMessage + + Should the generated class use "Maybe" for optional fields? + If Yes then + => This implies a new type class "Mergable" which is isomorphic to Data.Monoid but with instances needed to merge messages. + + Should the generated class use "Maybe" for required fields? + If No then + => This implies the API cannot return a partially filled in message + => This implies you cannot split the encoded bytes into two pieces then decode them into two messages and finially merge the two message, because one of the halves will be missing a required field! + If Yes then + => This implies that the type are more complicated and invalid message can be repesented. + diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -1,19 +1,19 @@ -name: protocol-buffers -version: 0.0.2 -cabal-version: >= 1.2 -build-type: Simple -license: BSD3 -license-file: LICENSE -copyright: (c) 2008 Christopher Edward Kuklewicz -author: Christopher Edward Kuklewicz -maintainer: Chris Kuklewicz -stability: vapor -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 +name: protocol-buffers +version: 0.0.5 +cabal-version: >= 1.2 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: (c) 2008 Christopher Edward Kuklewicz +author: Christopher Edward Kuklewicz +maintainer: Chris Kuklewicz +stability: Experimental +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 -category: Language +category: Text Tested-With: GHC ==6.8.3 -- data-files: extra-source-files: Setup.hs @@ -21,57 +21,50 @@ test -- extra-tmp-files: -Library - hs-source-dirs: ./src - exposed-modules: DescriptorProtos - DescriptorProtos.DescriptorProto.ExtensionRange - DescriptorProtos.DescriptorProto - DescriptorProtos.EnumDescriptorProto - DescriptorProtos.EnumOptions - DescriptorProtos.EnumValueDescriptorProto - DescriptorProtos.EnumValueOptions - DescriptorProtos.FieldDescriptorProto.Label - DescriptorProtos.FieldDescriptorProto.Type - DescriptorProtos.FieldDescriptorProto - DescriptorProtos.FieldOptions.CType - DescriptorProtos.FieldOptions - DescriptorProtos.FileDescriptorProto - DescriptorProtos.FileOptions.OptimizeMode - DescriptorProtos.FileOptions - DescriptorProtos.MessageOptions - DescriptorProtos.MethodDescriptorProto - DescriptorProtos.MethodOptions - DescriptorProtos.ServiceDescriptorProto - DescriptorProtos.ServiceOptions - ProtocolBuffers.Default - ProtocolBuffers.Header - ProtocolBuffers.Option - ProtocolBuffers.ParseProto - build-depends: derive - extensions: GADTs, EmptyDataDecls, TemplateHaskell, DeriveDataTypeable, FlexibleInstances +flag small_base + description: Choose the new smaller, split-up base package. --- Executable proto-hs --- main-is: --- build-depends: +Library + exposed-modules: Text.DescriptorProtos + Text.DescriptorProtos.DescriptorProto.ExtensionRange + Text.DescriptorProtos.DescriptorProto + Text.DescriptorProtos.EnumDescriptorProto + Text.DescriptorProtos.EnumOptions + Text.DescriptorProtos.EnumValueDescriptorProto + Text.DescriptorProtos.EnumValueOptions + Text.DescriptorProtos.FieldDescriptorProto.Label + Text.DescriptorProtos.FieldDescriptorProto.Type + Text.DescriptorProtos.FieldDescriptorProto + Text.DescriptorProtos.FieldOptions.CType + Text.DescriptorProtos.FieldOptions + Text.DescriptorProtos.FileDescriptorProto + Text.DescriptorProtos.FileOptions.OptimizeMode + Text.DescriptorProtos.FileOptions + Text.DescriptorProtos.MessageOptions + Text.DescriptorProtos.MethodDescriptorProto + Text.DescriptorProtos.MethodOptions + Text.DescriptorProtos.ServiceDescriptorProto + Text.DescriptorProtos.ServiceOptions + Text.ProtocolBuffers.Default + Text.ProtocolBuffers.Header + Text.ProtocolBuffers.Instances + Text.ProtocolBuffers.ParseProto + Text.ProtocolBuffers.WireMessage + Text.ProtocolBuffers.Mergeable + Text.ProtocolBuffers.DeriveMergeable + Text.ProtocolBuffers.Gen --- buildable: --- other-modules: --- hs-source-dirs: --- extensions: --- build-tools: --- ghc-options: token list --- ghc-prof-options: token list --- ghc-shared-options: token list --- hugs-options: token list --- nhc98-options: token list --- includes: filename list --- install-includes: filename list --- include-dirs: directory list --- c-sources: filename list --- extra-libraries: token list --- extra-lib-dirs: directory list --- cc-options: token list --- ld-options: token list --- pkgconfig-depends: package list --- frameworks: token list + if flag(small_base) + build-depends: base >= 3, + containers, + bytestring, + array + else + build-depends: base < 3 + build-depends: derive, parsec, utf8-string, haskell-src-exts + extensions: GADTs, + EmptyDataDecls, + TemplateHaskell, + DeriveDataTypeable, + FlexibleInstances diff --git a/src/DescriptorProtos.hs b/src/DescriptorProtos.hs deleted file mode 100644 --- a/src/DescriptorProtos.hs +++ /dev/null @@ -1,39 +0,0 @@ -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.ExtensionRange as DescriptorProtos.DescriptorProto(ExtensionRange) -import qualified DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) -import qualified DescriptorProtos.EnumOptions as DescriptorProtos(EnumOptions) -import qualified DescriptorProtos.EnumValueDescriptorProto as DescriptorProtos(EnumValueDescriptorProto) -import qualified DescriptorProtos.EnumValueOptions as DescriptorProtos(EnumValueOptions) -import qualified DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) -import qualified DescriptorProtos.FieldDescriptorProto.Label as DescriptorProtos.FieldDescriptorProto(Label) -import qualified DescriptorProtos.FieldDescriptorProto.Type as DescriptorProtos.FieldDescriptorProto(Type) -import qualified DescriptorProtos.FieldOptions as DescriptorProtos(FieldOptions) -import qualified DescriptorProtos.FieldOptions.CType as DescriptorProtos.FieldOptions(CType) -import qualified DescriptorProtos.FileOptions as DescriptorProtos(FileOptions) -import qualified DescriptorProtos.FileOptions.OptimizeMode as DescriptorProtos.FileOptions(OptimizeMode) -import qualified DescriptorProtos.MessageOptions as DescriptorProtos(MessageOptions) -import qualified DescriptorProtos.MethodDescriptorProto as DescriptorProtos(MethodDescriptorProto) -import qualified DescriptorProtos.MethodOptions as DescriptorProtos(MethodOptions) -import qualified DescriptorProtos.ServiceDescriptorProto as DescriptorProtos(ServiceDescriptorProto) -import qualified DescriptorProtos.ServiceOptions as DescriptorProtos(ServiceOptions) diff --git a/src/DescriptorProtos/DescriptorProto.hs b/src/DescriptorProtos/DescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/DescriptorProto.hs +++ /dev/null @@ -1,27 +0,0 @@ -module DescriptorProtos.DescriptorProto - (DescriptorProto(..)) - where - -import ProtocolBuffers.Header -import qualified DescriptorProtos.FileOptions as DescriptorProtos(FileOptions) -import qualified DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) -import qualified DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) -import qualified DescriptorProtos.MessageOptions as DescriptorProtos(MessageOptions) -import qualified DescriptorProtos.DescriptorProto.ExtensionRange as DescriptorProtos.DescriptorProto(ExtensionRange) - -data DescriptorProto = DescriptorProto - { 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 :: 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 diff --git a/src/DescriptorProtos/DescriptorProto/ExtensionRange.hs b/src/DescriptorProtos/DescriptorProto/ExtensionRange.hs deleted file mode 100644 --- a/src/DescriptorProtos/DescriptorProto/ExtensionRange.hs +++ /dev/null @@ -1,17 +0,0 @@ -module DescriptorProtos.DescriptorProto.ExtensionRange - (ExtensionRange(..)) - where - -import ProtocolBuffers.Header - -data ExtensionRange = ExtensionRange - { 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 diff --git a/src/DescriptorProtos/EnumDescriptorProto.hs b/src/DescriptorProtos/EnumDescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/EnumDescriptorProto.hs +++ /dev/null @@ -1,21 +0,0 @@ -module DescriptorProtos.EnumDescriptorProto - (EnumDescriptorProto(..)) - where - -import ProtocolBuffers.Header - -import qualified DescriptorProtos.EnumValueDescriptorProto as DescriptorProtos(EnumValueDescriptorProto) -import qualified DescriptorProtos.EnumOptions as DescriptorProtos(EnumOptions) - -data EnumDescriptorProto = EnumDescriptorProto - { name :: Optional ByteString - , value :: Seq DescriptorProtos.EnumValueDescriptorProto - , 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 diff --git a/src/DescriptorProtos/EnumOptions.hs b/src/DescriptorProtos/EnumOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/EnumOptions.hs +++ /dev/null @@ -1,14 +0,0 @@ -module DescriptorProtos.EnumOptions - (EnumOptions(..)) - where - -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 diff --git a/src/DescriptorProtos/EnumValueDescriptorProto.hs b/src/DescriptorProtos/EnumValueDescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/EnumValueDescriptorProto.hs +++ /dev/null @@ -1,19 +0,0 @@ -module DescriptorProtos.EnumValueDescriptorProto - (EnumValueDescriptorProto(..)) - where - -import ProtocolBuffers.Header -import qualified DescriptorProtos.EnumValueOptions as DescriptorProtos(EnumValueOptions) - -data EnumValueDescriptorProto = EnumValueDescriptorProto - { 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 diff --git a/src/DescriptorProtos/EnumValueOptions.hs b/src/DescriptorProtos/EnumValueOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/EnumValueOptions.hs +++ /dev/null @@ -1,14 +0,0 @@ -module DescriptorProtos.EnumValueOptions - (EnumValueOptions(..)) - where - -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 diff --git a/src/DescriptorProtos/FieldDescriptorProto.hs b/src/DescriptorProtos/FieldDescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/FieldDescriptorProto.hs +++ /dev/null @@ -1,26 +0,0 @@ -module DescriptorProtos.FieldDescriptorProto - (FieldDescriptorProto(..)) - where - -import ProtocolBuffers.Header -import qualified DescriptorProtos.FieldDescriptorProto.Label as DescriptorProtos.FieldDescriptorProto(Label) -import qualified DescriptorProtos.FieldDescriptorProto.Type as DescriptorProtos.FieldDescriptorProto(Type) -import qualified DescriptorProtos.FieldOptions as DescriptorProtos(FieldOptions) - -data FieldDescriptorProto = FieldDescriptorProto - { 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 diff --git a/src/DescriptorProtos/FieldDescriptorProto/Label.hs b/src/DescriptorProtos/FieldDescriptorProto/Label.hs deleted file mode 100644 --- a/src/DescriptorProtos/FieldDescriptorProto/Label.hs +++ /dev/null @@ -1,16 +0,0 @@ -module DescriptorProtos.FieldDescriptorProto.Label - (Label(..)) - where - -import ProtocolBuffers.Header - -data Label = LABEL_OPTIONAL - | LABEL_REQUIRED - | LABEL_REPEATED - deriving (Show,Eq,Ord,Typeable) - -instance OptionFlag a => Monoid (Option a Label) where - mempty = Absent - mappend = flip const - - diff --git a/src/DescriptorProtos/FieldDescriptorProto/Type.hs b/src/DescriptorProtos/FieldDescriptorProto/Type.hs deleted file mode 100644 --- a/src/DescriptorProtos/FieldDescriptorProto/Type.hs +++ /dev/null @@ -1,30 +0,0 @@ -module DescriptorProtos.FieldDescriptorProto.Type - (Type(..)) - where - -import 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,Eq,Ord,Typeable) - -instance OptionFlag a => Monoid (Option a Type) where - mempty = Absent - mappend = flip const diff --git a/src/DescriptorProtos/FieldOptions.hs b/src/DescriptorProtos/FieldOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/FieldOptions.hs +++ /dev/null @@ -1,20 +0,0 @@ -module DescriptorProtos.FieldOptions - (FieldOptions(..)) - where - -import ProtocolBuffers.Header - -import qualified DescriptorProtos.FieldOptions.CType as DescriptorProtos.FieldOptions(CType) - -data FieldOptions = FieldOptions - { 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 - diff --git a/src/DescriptorProtos/FieldOptions/CType.hs b/src/DescriptorProtos/FieldOptions/CType.hs deleted file mode 100644 --- a/src/DescriptorProtos/FieldOptions/CType.hs +++ /dev/null @@ -1,13 +0,0 @@ -module DescriptorProtos.FieldOptions.CType - (CType(..)) - where - -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 - diff --git a/src/DescriptorProtos/FileDescriptorProto.hs b/src/DescriptorProtos/FileDescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/FileDescriptorProto.hs +++ /dev/null @@ -1,28 +0,0 @@ -module DescriptorProtos.FileDescriptorProto - (FileDescriptorProto(..)) - where - -import ProtocolBuffers.Header -import qualified DescriptorProtos.DescriptorProto as DescriptorProtos(DescriptorProto) -import qualified DescriptorProtos.EnumDescriptorProto as DescriptorProtos(EnumDescriptorProto) -import qualified DescriptorProtos.FieldDescriptorProto as DescriptorProtos(FieldDescriptorProto) -import qualified DescriptorProtos.FileOptions as DescriptorProtos(FileOptions) -import qualified DescriptorProtos.ServiceDescriptorProto as DescriptorProtos(ServiceDescriptorProto) - -data FileDescriptorProto = FileDescriptorProto - { 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 :: 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 diff --git a/src/DescriptorProtos/FileOptions.hs b/src/DescriptorProtos/FileOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/FileOptions.hs +++ /dev/null @@ -1,25 +0,0 @@ -module DescriptorProtos.FileOptions - (FileOptions(..)) - where - -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 :: 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 - } diff --git a/src/DescriptorProtos/FileOptions/OptimizeMode.hs b/src/DescriptorProtos/FileOptions/OptimizeMode.hs deleted file mode 100644 --- a/src/DescriptorProtos/FileOptions/OptimizeMode.hs +++ /dev/null @@ -1,31 +0,0 @@ -module DescriptorProtos.FileOptions.OptimizeMode - (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 diff --git a/src/DescriptorProtos/MessageOptions.hs b/src/DescriptorProtos/MessageOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/MessageOptions.hs +++ /dev/null @@ -1,19 +0,0 @@ -module DescriptorProtos.MessageOptions - (MessageOptions(..)) - where - -import ProtocolBuffers.Header - -data MessageOptions = MessageOptions - { 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 - } diff --git a/src/DescriptorProtos/MethodDescriptorProto.hs b/src/DescriptorProtos/MethodDescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/MethodDescriptorProto.hs +++ /dev/null @@ -1,20 +0,0 @@ -module DescriptorProtos.MethodDescriptorProto - (MethodDescriptorProto(..)) - where - -import ProtocolBuffers.Header -import qualified DescriptorProtos.MethodOptions as DescriptorProtos(MethodOptions) - -data MethodDescriptorProto = MethodDescriptorProto - { 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 diff --git a/src/DescriptorProtos/MethodOptions.hs b/src/DescriptorProtos/MethodOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/MethodOptions.hs +++ /dev/null @@ -1,14 +0,0 @@ -module DescriptorProtos.MethodOptions - (MethodOptions(..)) - where - -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 diff --git a/src/DescriptorProtos/ServiceDescriptorProto.hs b/src/DescriptorProtos/ServiceDescriptorProto.hs deleted file mode 100644 --- a/src/DescriptorProtos/ServiceDescriptorProto.hs +++ /dev/null @@ -1,21 +0,0 @@ -module DescriptorProtos.ServiceDescriptorProto - (ServiceDescriptorProto(..)) - where - -import ProtocolBuffers.Header - -import qualified DescriptorProtos.MethodDescriptorProto as DescriptorProtos(MethodDescriptorProto) -import qualified DescriptorProtos.ServiceOptions as DescriptorProtos(ServiceOptions) - -data ServiceDescriptorProto = ServiceDescriptorProto - { name :: Optional ByteString - , method :: Seq DescriptorProtos.MethodDescriptorProto - , 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 diff --git a/src/DescriptorProtos/ServiceOptions.hs b/src/DescriptorProtos/ServiceOptions.hs deleted file mode 100644 --- a/src/DescriptorProtos/ServiceOptions.hs +++ /dev/null @@ -1,14 +0,0 @@ -module DescriptorProtos.ServiceOptions - (ServiceOptions(..)) - where - -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 diff --git a/src/ProtocolBuffers/Default.hs b/src/ProtocolBuffers/Default.hs deleted file mode 100644 --- a/src/ProtocolBuffers/Default.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ProtocolBuffers.Default(Default(..)) where - -import Data.Monoid - -class Monoid a => Default a where - defaultValue :: a - defaultValue = mempty diff --git a/src/ProtocolBuffers/Header.hs b/src/ProtocolBuffers/Header.hs deleted file mode 100644 --- a/src/ProtocolBuffers/Header.hs +++ /dev/null @@ -1,24 +0,0 @@ -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 diff --git a/src/ProtocolBuffers/Option.hs b/src/ProtocolBuffers/Option.hs deleted file mode 100644 --- a/src/ProtocolBuffers/Option.hs +++ /dev/null @@ -1,47 +0,0 @@ -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 diff --git a/src/ProtocolBuffers/ParseProto.hs b/src/ProtocolBuffers/ParseProto.hs deleted file mode 100644 --- a/src/ProtocolBuffers/ParseProto.hs +++ /dev/null @@ -1,195 +0,0 @@ -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" -