packages feed

proto-lens (empty) → 0.1.0.0

raw patch · 12 files changed

+1263/−0 lines, 12 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, containers, data-default-class, lens-family, parsec, pretty, text, transformers, void

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Google Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Google Inc. nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ proto-lens.cabal view
@@ -0,0 +1,45 @@+name:                proto-lens+version:             0.1.0.0+synopsis:            A lens-based implementation of protocol buffers in Haskell.+description:+  The proto-lens library provides to protocol buffers using modern+  Haskell language and library patterns.  Specifically, it provides:+  .+  * Composable field accessors via lenses+  .+  * Simple field name resolution/overloading via type-level literals+  .+  * Type-safe reflection and encoding/decoding of messages via GADTs++homepage:            https://github.com/google/proto-lens+license:             BSD3+license-file:        LICENSE+author:              Judah Jacobson+maintainer:          judahjacobson+protolens@google.com+copyright:           Google Inc.+category:            Data+build-type:          Simple+cabal-version:       >=1.8++library+  hs-source-dirs: src+  exposed-modules:     Data.ProtoLens+                       Data.ProtoLens.Encoding+                       Data.ProtoLens.Field+                       Data.ProtoLens.Message+                       Data.ProtoLens.Message.Enum+                       Data.ProtoLens.TextFormat+  other-modules:       Data.ProtoLens.Encoding.Bytes+                       Data.ProtoLens.Encoding.Wire+                       Data.ProtoLens.TextFormat.Parser+  build-depends:  attoparsec == 0.13.*+                , base == 4.8.*+                , bytestring == 0.10.*+                , containers == 0.5.*+                , data-default-class == 0.0.*+                , lens-family == 1.2.*+                , parsec == 3.1.*+                , pretty == 1.1.*+                , text == 1.2.*+                , transformers == 0.4.*+                , void == 0.7.*
+ src/Data/ProtoLens.hs view
@@ -0,0 +1,19 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++-- | The proto-lens package is a new implementation of protocol buffers in+-- Haskell.+module Data.ProtoLens (+    module Data.ProtoLens.Encoding,+    module Data.ProtoLens.Field,+    module Data.ProtoLens.Message,+    module Data.ProtoLens.TextFormat,+    ) where++import Data.ProtoLens.Encoding+import Data.ProtoLens.Field+import Data.ProtoLens.Message+import Data.ProtoLens.TextFormat
+ src/Data/ProtoLens/Encoding.hs view
@@ -0,0 +1,226 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++-- | Functions for encoding and decoding protocol buffer Messages.+--+-- TODO: Currently all operations are on strict ByteStrings;+-- we should try to generalize to lazy Bytestrings as well.+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.ProtoLens.Encoding(+    encodeMessage,+    buildMessage,+    decodeMessage,+    decodeMessageOrDie,+    ) where++import Data.ProtoLens.Message+import Data.ProtoLens.Encoding.Bytes+import Data.ProtoLens.Encoding.Wire++import Control.Applicative ((<|>), (<$>))+import Control.Monad (foldM)+import Data.Attoparsec.ByteString as Parse+import Data.Bool (bool)+import Data.Text.Encoding (encodeUtf8, decodeUtf8')+import Data.Text.Encoding.Error (UnicodeException(..))+import qualified Data.ByteString as B+import qualified Data.Map.Strict as Map+import Data.ByteString.Lazy.Builder as Builder+import qualified Data.ByteString.Lazy as L+import Data.Monoid (mconcat, mempty)+import Data.Foldable (foldMap, toList, foldl')+import Lens.Family2 (set, over, (^.), (&))++-- TODO: We could be more incremental when parsing/encoding length-based fields,+-- rather than forcing the whole thing.  E.g., for encoding we're doing extra+-- allocation by building an intermediate bytestring.++-- | Decode a message from its wire format.  Returns 'Left' if the decoding+-- fails.+decodeMessage :: Message msg => B.ByteString -> Either String msg+decodeMessage input =+    parseOnly (Parse.manyTill getTaggedValue endOfInput) input+        >>= taggedValuesToMessage++-- | Decode a message from its wire format.  Throws an error if the decoding+-- fails.+decodeMessageOrDie :: Message msg => B.ByteString -> msg+decodeMessageOrDie bs = case decodeMessage bs of+    Left e -> error $ "decodeMessageOrDie: " ++ e+    Right x -> x++-- | Convert a sequence of parsed key-value pairs into a Message via its+-- descriptor. Will fail if any of the key-value pairs do not match those+-- expected by the field descriptors.+taggedValuesToMessage :: Message msg => [TaggedValue] -> Either String msg+taggedValuesToMessage tvs+    | missing <- missingFields fields tvs, not $ null missing+        = Left $ "Missing required fields " ++ show missing+    | otherwise = reverseRepeatedFields fields <$> result+  where+    addTaggedValue msg tv@(TaggedValue tag _) =+        case Map.lookup (Tag tag) fields of+            Nothing -> return msg+            Just field -> parseAndAddField msg field tv+    fields = fieldsByTag descriptor+    result = foldM addTaggedValue def tvs++missingFields :: Map.Map Tag (FieldDescriptor msg) -> [TaggedValue] -> [String]+missingFields fields+    = map fieldDescriptorName+        . Map.elems+        . foldl' (\m (TaggedValue t _) -> Map.delete (Tag t) m) requiredFields+  where+    requiredFields = Map.filter isRequired fields++runEither :: Either String a -> Parser a+runEither (Left x) = fail x+runEither (Right x) = return x++parseAndAddField :: msg+                 -> FieldDescriptor msg+                 -> TaggedValue+                 -> Either String msg+parseAndAddField+    msg+    (FieldDescriptor name typeDescriptor accessor)+    (TaggedValue tag (WireValue wt val))+    = case fieldWireType typeDescriptor of+        FieldWireType fieldWt _ get -> let+          getSimpleVal = do+              Equal <- equalWireTypes name fieldWt wt+              get val+          -- Get a block of packed values, reversed.+          getPackedVals = do+              Equal <- equalWireTypes name Lengthy wt+              let getElt = getWireValue fieldWt tag >>= runEither . get+              parseOnly (manyReversedTill getElt endOfInput) val+          in case accessor of+              PlainField _ f -> do+                  x <- getSimpleVal+                  return $ set f x msg+              OptionalField f -> do+                  x <- getSimpleVal+                  return $ set f (Just x) msg+              RepeatedField Unpacked f -> do+                  x <- getSimpleVal+                  return $ over f (x:) msg+              RepeatedField Packed f -> do+                  xs <- getPackedVals+                  return $ over f (xs++) msg+              MapField keyLens valueLens f -> do+                  entry <- getSimpleVal+                  return $ over f+                      (Map.insert (entry ^. keyLens) (entry ^. valueLens))+                      msg++-- | Run the parser zero or more times, until the "end" parser succeeds.+-- Returns a list of the parsed elements, in reverse order.+manyReversedTill :: Parser a -> Parser b -> Parser [a]+manyReversedTill p end = loop []+  where+    loop xs = (end >> return xs) <|> (p >>= \x -> loop (x:xs))++-- | Encode a message to the wire format.+encodeMessage :: Message msg => msg -> B.ByteString+encodeMessage = L.toStrict . toLazyByteString . buildMessage++-- | Encode a message to the wire format, as part of a 'Builder'.+buildMessage :: Message msg => msg -> Builder+buildMessage msg = foldMap putTaggedValue (messageToTaggedValues msg)++-- | Encode a message as a sequence of key-value pairs.+messageToTaggedValues :: Message msg => msg -> [TaggedValue]+messageToTaggedValues msg = mconcat+    [ map (TaggedValue t) (messageFieldToVals fieldDescr msg)+    | (Tag t, fieldDescr) <- Map.toList (fieldsByTag descriptor)+    ]++messageFieldToVals :: FieldDescriptor msg -> msg -> [WireValue]+messageFieldToVals (FieldDescriptor _ typeDescriptor accessor) msg =+    case fieldWireType typeDescriptor of+        FieldWireType wt convert _ -> case accessor of+            PlainField d f+                | Optional <- d, src == fieldDefault -> []+                | otherwise -> [WireValue wt (convert src)]+              where src = msg ^. f+            OptionalField f -> case msg ^. f of+                Just src -> [WireValue wt (convert src)]+                _ -> mempty+            RepeatedField Unpacked f+                -> [ WireValue wt (convert src)+                   | src <- toList (msg ^. f)+                   ]+            RepeatedField Packed f+                -> [WireValue Lengthy v]+                     where v = L.toStrict $ toLazyByteString+                               $ mconcat+                                 [ putWireValue wt (convert src)+                                 | src <- toList (msg ^. f)+                                 ]+            MapField keyLens valueLens f ->+                [ WireValue wt v+                | (key, value) <- Map.toList (msg ^. f)+                , let entry = def & set keyLens key & set valueLens value+                , let v = convert entry+                ]++data FieldWireType value where+    FieldWireType :: WireType w -> (value -> w) -> (w -> Either String value)+                  -> FieldWireType value++fieldWireType :: FieldTypeDescriptor value -> FieldWireType value+-- TODO: Don't let toEnum crash on unknown enum values.+fieldWireType EnumField = simpleFieldWireType VarInt+                              (fromIntegral . fromEnum)+                              (toEnum . fromIntegral)+fieldWireType BoolField = simpleFieldWireType VarInt (bool 0 1) (/= 0)+-- Note: int{32,64} and sfixed{32,64} are stored using the signed -> unsigned+-- conversion of fromIntegral.+fieldWireType Int32Field = integralFieldWireType VarInt+fieldWireType Int64Field = integralFieldWireType VarInt+fieldWireType UInt32Field = integralFieldWireType VarInt+fieldWireType UInt64Field = identityFieldWireType VarInt+fieldWireType SInt32Field = simpleFieldWireType VarInt+                                (fromIntegral . signedInt32ToWord)+                                (wordToSignedInt32 . fromIntegral)+fieldWireType SInt64Field = simpleFieldWireType VarInt+                                signedInt64ToWord wordToSignedInt64+fieldWireType Fixed32Field = identityFieldWireType Fixed32+fieldWireType Fixed64Field = identityFieldWireType Fixed64+fieldWireType SFixed32Field = integralFieldWireType Fixed32+fieldWireType SFixed64Field = integralFieldWireType Fixed64+fieldWireType FloatField = simpleFieldWireType Fixed32 floatToWord wordToFloat+fieldWireType DoubleField = simpleFieldWireType Fixed64+                                doubleToWord wordToDouble+fieldWireType StringField = FieldWireType Lengthy encodeUtf8+                                                  (stringizeError . decodeUtf8')+fieldWireType BytesField = identityFieldWireType Lengthy+fieldWireType MessageField = FieldWireType Lengthy encodeMessage decodeMessage+fieldWireType GroupField =+    FieldWireType StartGroup messageToTaggedValues taggedValuesToMessage++-- | Helper function to define a field type whose decoding operation can't fail.+simpleFieldWireType :: WireType w -> (value -> w) -> (w -> value)+                    -> FieldWireType value+simpleFieldWireType w f g = FieldWireType w f (return . g)++-- | A simple field type which is the same as its wire type.+identityFieldWireType :: WireType w -> FieldWireType w+identityFieldWireType w = simpleFieldWireType w id id++-- | A simple field type which converts to/from its wire type via+-- "fromIntegral".+integralFieldWireType+    :: (Integral w, Integral value) => WireType w -> FieldWireType value+integralFieldWireType w = simpleFieldWireType w fromIntegral fromIntegral++stringizeError :: Either UnicodeException a -> Either String a+stringizeError (Left e) = Left (show e)+stringizeError (Right a) = Right a+
+ src/Data/ProtoLens/Encoding/Bytes.hs view
@@ -0,0 +1,104 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Utility functions for parsing and encoding individual types.+module Data.ProtoLens.Encoding.Bytes(+    getVarInt,+    putVarInt,+    anyBits,+    wordToFloat,+    wordToDouble,+    floatToWord,+    doubleToWord,+    signedInt32ToWord,+    wordToSignedInt32,+    signedInt64ToWord,+    wordToSignedInt64,+    ) where++import Data.Attoparsec.ByteString as Parse+import Data.Bits+import Data.ByteString.Lazy.Builder as Builder+import Data.Int (Int32, Int64)+import Data.Monoid ((<>))+import Data.Word (Word32, Word64)+import Foreign.Ptr (castPtr)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (Storable, peek, poke)+import System.IO.Unsafe (unsafePerformIO)++-- VarInts are inherently unsigned; there are different ways of encoding+-- negative numbers for int32/64 and sint32/64.+getVarInt :: Parser Word64+getVarInt = loop 1 0+  where+  -- TODO: bang pattern?+    loop s n = do+        b <- anyWord8+        let n' = n + s * fromIntegral (b .&. 127)+        if (b .&. 128) == 0+            then return n'+            else loop (128*s) n'++-- | Little-endian decoding function.+anyBits :: forall a . (Num a, FiniteBits a) => Parser a+anyBits = loop 0 0+  where+    size = finiteBitSize (undefined :: a)+    loop w n+        | n >= size = return w+        | otherwise = do+            b <- anyWord8+            loop (w .|. shiftL (fromIntegral b) n) (n+8)++putVarInt :: Word64 -> Builder+putVarInt n+    | n < 128 = Builder.word8 (fromIntegral n)+    | otherwise = Builder.word8 (fromIntegral $ n .&. 127 .|. 128)+                      <> putVarInt (n `shiftR` 7)++-- WARNING: SUPER UNSAFE!+-- Helper function purely for converting between Word32/Word64 and+-- Float/Double.  Note that ideally we could just use unsafeCoerce, but this+-- breaks with -O2 since it violates some assumptions in Core.  As a result,+-- poking the FFI turns out to be a more reliable way to do these casts.+-- For more information see:+-- https://ghc.haskell.org/trac/ghc/ticket/2209+-- https://ghc.haskell.org/trac/ghc/ticket/4092+{-# INLINE cast #-}+cast :: (Storable a, Storable b) => a -> b+cast x = unsafePerformIO $ alloca $ \p -> do+            poke p x+            peek $ castPtr p++wordToDouble :: Word64 -> Double+wordToDouble = cast++wordToFloat :: Word32 -> Float+wordToFloat = cast++doubleToWord :: Double -> Word64+doubleToWord = cast++floatToWord :: Float -> Word32+floatToWord = cast++signedInt32ToWord :: Int32 -> Word32+signedInt32ToWord n = fromIntegral $ shiftL n 1 `xor` shiftR n 31++wordToSignedInt32 :: Word32 -> Int32+wordToSignedInt32 n+    = fromIntegral (shiftR n 1) `xor` negate (fromIntegral $ n .&. 1)++signedInt64ToWord :: Int64 -> Word64+signedInt64ToWord n = fromIntegral $ shiftL n 1 `xor` shiftR n 63++wordToSignedInt64 :: Word64 -> Int64+wordToSignedInt64 n+    = fromIntegral (shiftR n 1) `xor` negate (fromIntegral $ n .&. 1)
+ src/Data/ProtoLens/Encoding/Wire.hs view
@@ -0,0 +1,134 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+-- | Module defining the individual base wire types (e.g. VarInt, Fixed64) and+-- how to encode/decode them.+module Data.ProtoLens.Encoding.Wire(+    WireType(..),+    SomeWireType(..),+    WireValue(..),+    TaggedValue(..),+    getTaggedValue,+    putTaggedValue,+    getWireValue,+    putWireValue,+    Equal(..),+    equalWireTypes,+    ) where++import Data.Attoparsec.ByteString as Parse+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.ByteString.Lazy.Builder as Builder+import Data.Foldable (foldMap)+import Data.Monoid ((<>), mempty)+import Data.Void (Void)+import Data.Word++import Data.ProtoLens.Encoding.Bytes++data WireType a where+    VarInt :: WireType Word64+    Fixed64 :: WireType Word64+    Fixed32 :: WireType Word32+    Lengthy :: WireType B.ByteString+    StartGroup :: WireType [TaggedValue]+    EndGroup :: WireType Void++-- A value read from the wire+data WireValue = forall a . WireValue !(WireType a) !a+-- The wire contents of a single key-value pair in a Message.+data TaggedValue = TaggedValue !Int !WireValue++instance Show (WireType a) where+    show = show . wireTypeToInt++data Equal a b where+    Equal :: Equal a a++-- Assert that two wire types are the same, or fail with a message about this+-- field.+equalWireTypes :: String -> WireType a -> WireType b+               -> Either String (Equal a b)+equalWireTypes _ VarInt VarInt = Right Equal+equalWireTypes _ Fixed64 Fixed64 = Right Equal+equalWireTypes _ Fixed32 Fixed32 = Right Equal+equalWireTypes _ Lengthy Lengthy = Right Equal+equalWireTypes _ StartGroup StartGroup = Right Equal+equalWireTypes _ EndGroup EndGroup = Right Equal+equalWireTypes name expected actual+    = Left $ "Field " ++ name ++ " expects wire type " ++ show expected+        ++ " but found " ++ show actual++getWireValue :: WireType a -> Int -> Parser a+getWireValue VarInt _ = getVarInt+getWireValue Fixed64 _ = anyBits+getWireValue Fixed32 _ = anyBits+getWireValue Lengthy _ = getVarInt >>= Parse.take . fromIntegral+-- Precompute the final EndGroup tag and keep parsing key-value pairs until+-- we reach the EndGroup.+getWireValue StartGroup tag = Parse.manyTill getTaggedValue end+  where+    typeAndTag = BL.toStrict $ toLazyByteString (putTypeAndTag EndGroup tag)+    end = Parse.string typeAndTag+getWireValue EndGroup tag =+    fail $ "Encountered unexpected end of group with tag " ++ show tag++putWireValue :: WireType a -> a -> Builder+putWireValue VarInt n = putVarInt n+putWireValue Fixed64 n = word64LE n+putWireValue Fixed32 n = word32LE n+putWireValue Lengthy b = putVarInt (fromIntegral $ B.length b) <> byteString b+putWireValue StartGroup tvs = foldMap putTaggedValue tvs+putWireValue EndGroup _ = mempty++data SomeWireType where+    SomeWireType :: WireType a -> SomeWireType++wireTypeToInt :: WireType a -> Word64+wireTypeToInt VarInt = 0+wireTypeToInt Fixed64 = 1+wireTypeToInt Lengthy = 2+wireTypeToInt StartGroup = 3+wireTypeToInt EndGroup = 4+wireTypeToInt Fixed32 = 5++intToWireType :: Word64 -> Either String SomeWireType+intToWireType 0 = Right $ SomeWireType VarInt+intToWireType 1 = Right $ SomeWireType Fixed64+intToWireType 2 = Right $ SomeWireType Lengthy+intToWireType 3 = Right $ SomeWireType StartGroup+intToWireType 4 = Right $ SomeWireType EndGroup+intToWireType 5 = Right $ SomeWireType Fixed32+intToWireType n = Left $ "Unrecognized wire type " ++ show n++putTypeAndTag :: WireType a -> Int -> Builder+putTypeAndTag wt tag+    = putVarInt $ wireTypeToInt wt .|. fromIntegral tag `shiftL` 3++getTypeAndTag :: Parser (SomeWireType, Int)+getTypeAndTag = do+  n <- getVarInt+  case intToWireType (n .&. 7) of+    Left err -> fail err+    Right wt -> return (wt, fromIntegral $ n `shiftR` 3)++getTaggedValue :: Parser TaggedValue+getTaggedValue = do+    (SomeWireType wt, tag) <- getTypeAndTag+    val <- getWireValue wt tag+    return $ TaggedValue tag (WireValue wt val)++putTaggedValue :: TaggedValue -> Builder+putTaggedValue (TaggedValue tag (WireValue StartGroup val)) =+    putTypeAndTag StartGroup tag+    <> putWireValue StartGroup val+    <> putTypeAndTag EndGroup tag+putTaggedValue (TaggedValue tag (WireValue wt val)) =+    putTypeAndTag wt tag <> putWireValue wt val
+ src/Data/ProtoLens/Field.hs view
@@ -0,0 +1,75 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- | A simple interface supporting overloaded record fields.+--+-- An example instance:+--+-- > data Foo = Foo { _bar :: Bool }+-- > type instance Field "bar" Foo = Bool+-- >+-- > instance HasField "bar" Foo Foo where+-- >     field _ = lens _bar (\f x -> f { _bar = x })+-- >+-- > bar :: HasField "bar" a a => Lens a b Bool Bool+-- > bar = field (ProxySym :: ProxySym "bar")+--+-- The proto compiler defines separate instances of 'HasField' for each field+-- of each record.  It defines the accessors (e.g., the lens @bar@ above) once+-- per unique field name, shared between different message types within the+-- same module.+module Data.ProtoLens.Field+    ( -- * Overloaded fields+     Field+    , HasField(..)+    , ProxySym(..)+    -- * Helper lenses+    , maybeLens+    ) where++import Data.Maybe (fromMaybe)+import GHC.TypeLits (Symbol)+import Lens.Family2 (Lens, Lens')+import Lens.Family2.Unchecked (lens)++-- | A \"proxy\" value for a type-level string (i.e., a type of kind 'Symbol').+data ProxySym (s :: Symbol) = ProxySym++-- | The type of the field 's' in a message of type 'a'.+type family Field (s :: Symbol) a++-- | A class for overloaded fields.+--+-- - 's' is a 'Symbol' representing the field name.+-- - 'a' is the message type for getting this field+-- - 'b' is the message type after setting this field.+--+-- Currently 'a' and 'b' are the same in all generated instances.  In the+-- future, when we support type-checking of required fields we'll need+-- different 'a' and 'b'; for more details see <go/proto-lens>.+class HasField (s :: Symbol) a b | a -> b, b -> a where+    field :: ProxySym s -> Lens a b (Field s a) (Field s b)++-- | A helper lens for accessing optional fields.+-- This is used as part of code generation, and should generally not be needed+-- explicitly.+--+-- Note that 'maybeLens' does not satisfy the lens laws, which expect that @set+-- l (view l x) == x@.  For example,+--+-- > set (maybeLens 'a') (view (maybeLens 'a') Nothing) == Just 'a'+--+-- However, this is the behavior generally expected by users, and only matters+-- if we're explicitly checking whether a field is set.+maybeLens :: b -> Lens' (Maybe b) b+maybeLens x = lens (fromMaybe x) $ const Just
+ src/Data/ProtoLens/Message.hs view
@@ -0,0 +1,210 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Datatypes for reflection of protocol buffer messages.+module Data.ProtoLens.Message (+    -- * Reflection of Messages+    Message(..),+    Tag(..),+    MessageDescriptor(..),+    FieldDescriptor(..),+    fieldDescriptorName,+    isRequired,+    FieldAccessor(..),+    WireDefault(..),+    Packing(..),+    FieldTypeDescriptor(..),+    FieldDefault(..),+    MessageEnum(..),+    -- * Building protocol buffers+    Default(..),+    build,+    -- * Internal utilities for parsing protocol buffers+    reverseRepeatedFields,+    ) where++import qualified Data.ByteString as B+import Data.Default.Class+import Data.Int+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Text as T+import Data.Word+import Lens.Family2 (Lens', over)++-- | Every protocol buffer is an instance of 'Message'.  This class enables+-- serialization by providing reflection of all of the fields that may be used+-- by this type.+class Default msg => Message msg where+    descriptor :: MessageDescriptor msg++-- | The description of a particular protocol buffer message type.+data MessageDescriptor msg = MessageDescriptor+    { fieldsByTag :: Map Tag (FieldDescriptor msg)+    , fieldsByTextFormatName :: Map String (FieldDescriptor msg)+      -- ^ This map is keyed by the name of the field used for text format protos.+      -- This is just the field name for every field except for group fields,+      -- which use their Message type name in text protos instead of their+      -- field name. For example, "optional group Foo" has the field name "foo"+      -- but in this map it is stored with the key "Foo".+    }++-- | A tag that identifies a particular field of the message when converting+-- to/from the wire format.+newtype Tag = Tag { unTag :: Int}+    deriving (Show, Eq, Ord, Num)+++-- | A description of a specific field of a protocol buffer.+--+-- The 'String' parameter is the original name of the field in the .proto file.+-- (Haddock doesn't support per-argument docs for GADTs.)+data FieldDescriptor msg where+    FieldDescriptor :: String+                    -> FieldTypeDescriptor value -> FieldAccessor msg value+                    -> FieldDescriptor msg++-- | The original name of the field in the .proto file.+fieldDescriptorName :: FieldDescriptor msg -> String+fieldDescriptorName (FieldDescriptor name _ _) = name++-- | Whether the given field is required.  Specifically, if its 'FieldAccessor'+-- is a 'Required' 'PlainField'.+isRequired :: FieldDescriptor msg -> Bool+isRequired (FieldDescriptor _ _ (PlainField Required _)) = True+isRequired _ = False++-- | A Lens for accessing the value of an individual field in a protocol buffer+-- message.+data FieldAccessor msg value where+    -- A field which is stored in the proto as just a value.  Used for+    -- required fields and proto3 optional scalar fields.+    PlainField :: WireDefault value -> Lens' msg value+                     -> FieldAccessor msg value+    -- An optional field where the "unset" and "default" values are+    -- distinguishable.  In particular: proto2 optional fields, proto3+    -- messages, and "oneof" fields.+    OptionalField :: Lens' msg (Maybe value) -> FieldAccessor msg value+    RepeatedField :: Packing -> Lens' msg [value] -> FieldAccessor msg value+    -- A proto "map" field is serialized as a repeated field of an+    -- autogenerated "entry" type, where each entry contains a single key/value+    -- pair.  This constructor provides lenses for accessing the key and value+    -- of each entry, so that we can covert between a list of entries and a Map.+    MapField :: (Ord key, Message entry) => Lens' entry key -> Lens' entry value+                      -> Lens' msg (Map key value) -> FieldAccessor msg entry++-- | The default value (if any) for a 'PlainField' on the wire.+data WireDefault value where+    -- Required fields have no default.+    Required :: WireDefault value+    -- Corresponds to proto3 scalar fields.+    Optional :: (FieldDefault value, Eq value) => WireDefault value++-- | A proto3 field type with an implicit default value.+--+-- This is distinct from 'Data.Default' to avoid orphan instances, and because+-- 'Bool' doesn't necessarily have a good Default instance for general usage.+class FieldDefault value where+    fieldDefault :: value++instance FieldDefault Bool where+    fieldDefault = False++instance FieldDefault Int32 where+    fieldDefault = 0++instance FieldDefault Int64 where+    fieldDefault = 0++instance FieldDefault Word32 where+    fieldDefault = 0++instance FieldDefault Word64 where+    fieldDefault = 0++instance FieldDefault Float where+    fieldDefault = 0++instance FieldDefault Double where+    fieldDefault = 0++instance FieldDefault B.ByteString where+    fieldDefault = B.empty++instance FieldDefault T.Text where+    fieldDefault = T.empty+++-- | How a given repeated field is transmitted on the wire format.+data Packing = Packed | Unpacked++-- | A description of the type of a given field value.+data FieldTypeDescriptor value where+    MessageField :: Message value => FieldTypeDescriptor value+    GroupField :: Message value => FieldTypeDescriptor value+    EnumField :: MessageEnum value => FieldTypeDescriptor value+    Int32Field :: FieldTypeDescriptor Int32+    Int64Field :: FieldTypeDescriptor Int64+    UInt32Field :: FieldTypeDescriptor Word32+    UInt64Field :: FieldTypeDescriptor Word64+    SInt32Field :: FieldTypeDescriptor Int32+    SInt64Field :: FieldTypeDescriptor Int64+    Fixed32Field :: FieldTypeDescriptor Word32+    Fixed64Field :: FieldTypeDescriptor Word64+    SFixed32Field :: FieldTypeDescriptor Int32+    SFixed64Field :: FieldTypeDescriptor Int64+    FloatField :: FieldTypeDescriptor Float+    DoubleField :: FieldTypeDescriptor Double+    BoolField :: FieldTypeDescriptor Bool+    StringField :: FieldTypeDescriptor T.Text+    BytesField :: FieldTypeDescriptor B.ByteString++deriving instance Show (FieldTypeDescriptor value)++-- | A class for protocol buffer enums that enables safe decoding.+class (Enum a, Bounded a) => MessageEnum a where+    -- | Convert the given 'Int' to an enum value.  Returns 'Nothing' if+    -- no corresponding value was defined in the .proto file.+    maybeToEnum :: Int -> Maybe a+    -- | Get the name of this enum as defined in the .proto file.+    showEnum :: a -> String+    -- | Convert the given 'String' to an enum value. Returns 'Nothing' if+    -- no corresponding value was defined in the .proto file.+    readEnum :: String -> Maybe a++-- | Utility function for building a message from a default value.+-- For example:+--+-- > instance Default A where ...+-- > x, y :: Lens' A Int+-- > m :: A+-- > m = build ((x .~ 5) . (y .~ 7))+build :: Default a => (a -> a) -> a+build = ($ def)++-- | Reverse every repeated (list) field in the message.+--+-- During parsing, we store fields temporarily in reverse order,+-- and then un-reverse them at the end.  This helps avoid the quadratic blowup+-- from repeatedly appending to lists.+-- TODO: Benchmark how much of a problem this is in practice,+-- and whether it's still a net win for small protobufs.+-- If we decide on it more permanently, consider moving it to a more internal+-- module.+reverseRepeatedFields :: Map k (FieldDescriptor msg) -> msg -> msg+reverseRepeatedFields fields x0+    -- TODO: if it becomes a bottleneck, consider forcing+    -- the full spine of each list.+    = Map.foldl' reverseListField x0 fields+  where+    reverseListField :: a -> FieldDescriptor a -> a+    reverseListField x (FieldDescriptor _ _ (RepeatedField _ f))+        = over f reverse x+    reverseListField x _ = x
+ src/Data/ProtoLens/Message/Enum.hs view
@@ -0,0 +1,99 @@+-- | This internal module provides functions used to define the various+-- @enumFrom*@ functions of 'Enum'.+--+-- We expect 'fromEnum' to be an ordering homomorphism, that is:+--+-- @+-- forall a b. Enum a b+-- succ a == b => fromEnum a < fromEnum b+-- @+--+-- Note that this homomorphism is most likely not surjective.  Note further that+-- one cannot assume:+--+-- @+-- CANNOT BE ASSUMED !+-- succ a == b => fromEnum a + 1 == fromEnum b+-- @+--+-- The 'succ' essor of a given message enum value @A@ that's not 'maxBound' is+-- the enum value @B@ whose 'fromEnum' value is the one immediately after @A@'s+-- 'fromEnum' value.  That is, 'fromEnum' determines order, but not distance.+--+-- As an example, consider the enum in the test suite:+--+-- @+-- enum Baz {+--     BAZ1 = 1; BAZ2 = 2; BAZ3 = 4; BAZ4 = 6;+--     BAZ5 = 7; BAZ6 = 9; BAZ7 = 10; BAZ8 = 12;+-- }+-- @+--+-- In this case, @succ BAZ2@ is @BAZ3@ despite their fromEnum values differing+-- by 2.  Further, @[BAZ2, BAZ4 ..]@ or equivalently+-- @messageEnumFromThen BAZ2 BAZ4@ is every other enum (i.e. a distance of 2)+-- when taken as a list, i.e.  @[BAZ2, BAZ4, BAZ6, BAZ8]@ despite the+-- 'fromEnum' distances being @[4, 3, 3]@.+--+-- That said, it is highly unwise to use any of the @[a,b ..*]@ patterns or+-- @enumFromThen*@ functions since adding or removing enums values can cause+-- previously functioning code to fail.  I.e. removing @BAZ3@ in the above+-- example makes the result equivalent @fromEnum BAZ2@ and the sequence now+-- includes every enum value save @BAZ1@.  This is all despite the fact that+-- @BAZ3@ was never referenced.+module Data.ProtoLens.Message.Enum+    ( messageEnumFrom+    , messageEnumFromTo+    , messageEnumFromThen+    , messageEnumFromThenTo+    ) where++import Data.List (unfoldr)+import Data.Ord (comparing)++messageEnumFromTo :: Enum a => a -> a -> [a]+messageEnumFromTo start stop = case comparing fromEnum start stop of+    LT -> messageEnumFromThenTo start (succ start) stop+    -- The only time we can't call 'succ' on @start@ is if it's 'maxBound' which+    -- is >= all values by definition, so the below cases cover all possible+    -- cases where succ cannot be called.+    EQ -> [start]+    GT -> []++messageEnumFrom :: (Enum a, Bounded a) => a -> [a]+messageEnumFrom = flip messageEnumFromTo maxBound++messageEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a]+messageEnumFromThen start step = case comparing fromEnum start step of+    LT -> messageEnumFromThenTo start step maxBound+    EQ -> repeat start+    GT -> messageEnumFromThenTo start step minBound++messageEnumFromThenTo :: Enum a => a -> a -> a -> [a]+messageEnumFromThenTo start step stop = case comparing fromEnum start step of+    LT -> helper succ GT+    EQ -> if stopInt >= stepInt then repeat start else []+    GT -> helper pred LT+  where+    stopInt = fromEnum stop+    stepInt = fromEnum step+    helper iter isAfter+        | comparing fromEnum start stop == isAfter = []+        | compare stepInt stopInt == isAfter = [start]+        | otherwise = start : unfoldr (fmap unfoldIter) (Just step)+      where+        -- This applies @iter@ (which is either succ or pred depending on our+        -- direction) @n@ times.  This returns @Just@ the result unless we've+        -- passed @stop@, in which case we return @Nothing@.+        jump 0 a = Just a+        jump n a+            | stopInt == fromEnum a = Nothing+            | otherwise = jump (n-1) $ iter a+        unfoldIter a = (a, jump skipCount a)+        countSkips n start'+            | stepInt == fromEnum start' = n+            | otherwise = countSkips (n+1) $ iter start'+        -- This is the number of applications of @iter@ (again, either @succ@+        -- or @pred@) needed to get from @start@ to @step@.+        skipCount = countSkips 0 start+
+ src/Data/ProtoLens/TextFormat.hs view
@@ -0,0 +1,216 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++-- | Functions for converting protocol buffers to a human-readable text format.+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.ProtoLens.TextFormat(+    showMessage,+    showMessageShort,+    pprintMessage,+    readMessage,+    readMessageOrDie,+    ) where++import Lens.Family2 ((&),(^.),(.~), set, over)+import Control.Applicative ((<$>))+import Control.Arrow (left)+import qualified Data.ByteString.Char8 as B+import Data.Foldable (foldlM, foldl')+import Data.Maybe (catMaybes)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy+import Text.Parsec (parse)+import Text.PrettyPrint++import Data.ProtoLens.Message+import qualified Data.ProtoLens.TextFormat.Parser as Parser++-- TODO: This code is newer and missing some edge cases,+-- including:+-- - Serialize directly to Text+-- - String/bytestring serialization+--   - Strings delimited by single quotes+--   - Concatenate multiple strings one after another+--   - control characters and non-UTF8 text+--   - characters in bytes fields should fit in Word8+-- - More output formats for floats like exponentials+-- - Print/parse enums by textual name in addition to integer value+-- - More compact printing/parsing for packed fields+-- - Decide what to do for values that don't fit in the field (e.g., overflow)+-- - Add more tests for:+--   - edge cases of deserialization ("deserializeFrom")+++-- | Pretty-print the given message into a human-readable form.+pprintMessage :: Message msg => msg -> Doc+pprintMessage = pprintMessage' descriptor++-- | Convert the given message into a human-readable 'String'.+showMessage :: Message msg => msg -> String+showMessage = render . pprintMessage++-- | Serializes a proto as a string on a single line.  Useful for debugging+-- and error messages like @.DebugString()@ in other languages.+showMessageShort :: Message msg => msg -> String+showMessageShort = renderStyle (Style OneLineMode maxBound 1.5) . pprintMessage++pprintMessage' :: MessageDescriptor msg -> msg -> Doc+pprintMessage' descr msg+    -- Either put all fields together on a single line, or use a separate line+    -- for each field.  We use a single "sep" for all fields (and all elements+    -- of all the repeated fields) to avoid putting some repeated fields on one+    -- line and other fields on multiple lines, which is less readable.+    = sep $ concatMap (pprintField msg) $ Map.toList+        $ fieldsByTextFormatName descr++pprintField :: msg -> (String, FieldDescriptor msg) -> [Doc]+pprintField msg (name, FieldDescriptor _ typeDescr accessor)+    = map (pprintFieldValue name typeDescr) $ case accessor of+        PlainField d f+            | Optional <- d, val == fieldDefault -> []+            | otherwise -> [val]+          where val = msg ^. f+        OptionalField f -> catMaybes [msg ^. f]+        -- TODO: better printing for packed fields+        RepeatedField _ f -> msg ^. f+        MapField k v f -> pairToMsg <$> Map.assocs (msg ^. f)+          where pairToMsg (x,y) = def & k .~ x+                                      & v .~ y++pprintFieldValue :: String -> FieldTypeDescriptor value -> value -> Doc+pprintFieldValue name MessageField m+    = sep [text name <+> lbrace, nest 2 (pprintMessage m), rbrace]+-- TODO: make this output the enum value name by default+pprintFieldValue name EnumField x = primField name $ fromEnum x+pprintFieldValue name Int32Field x = primField name x+pprintFieldValue name Int64Field x = primField name x+pprintFieldValue name UInt32Field x = primField name x+pprintFieldValue name UInt64Field x = primField name x+pprintFieldValue name SInt32Field x = primField name x+pprintFieldValue name SInt64Field x = primField name x+pprintFieldValue name Fixed32Field x = primField name x+pprintFieldValue name Fixed64Field x = primField name x+pprintFieldValue name SFixed32Field x = primField name x+pprintFieldValue name SFixed64Field x = primField name x+pprintFieldValue name FloatField x = primField name x+pprintFieldValue name DoubleField x = primField name x+pprintFieldValue name BoolField x = text name <> colon <+> boolValue x+pprintFieldValue name StringField x = primField name x+pprintFieldValue name BytesField x = primField name x+pprintFieldValue name GroupField m+    = text name <+> lbrace $$ nest 2 (pprintMessage m) $$ rbrace++primField :: Show value => String -> value -> Doc+primField name x = text name <> colon <+> text (show x)++boolValue :: Bool -> Doc+boolValue True = text "true"+boolValue False = text "false"++--------------------------------------------------------------------------------+-- Parsing++-- | Parse a 'Message' from the human-readable protocol buffer text format.+readMessage :: Message msg => Lazy.Text -> Either String msg+readMessage str = left show (parse Parser.parser "" str) >>= buildMessage++-- | Parse a 'Message' from the human-readable protocol buffer text format.+-- Throws an error if the parse was not successful.+readMessageOrDie :: Message msg => Lazy.Text -> msg+readMessageOrDie str = case readMessage str of+    Left e -> error $ "readMessageOrDie: " ++ e+    Right x -> x++buildMessage :: forall msg . Message msg => Parser.Message -> Either String msg+buildMessage fields+    | missing <- missingFields desc fields, not $ null missing+        = Left $ "Missing fields " ++ show missing+    | otherwise = reverseRepeatedFields (fieldsByTag desc)+                      <$> buildMessageFromDescriptor desc def fields+  where+    desc :: MessageDescriptor msg+    desc = descriptor++missingFields :: MessageDescriptor msg -> Parser.Message -> [String]+missingFields desc = Set.toList . foldl' deleteField requiredFieldNames+  where+    requiredFieldNames :: Set.Set String+    requiredFieldNames = Set.fromList $ Map.keys+                            $ Map.filter isRequired+                            $ fieldsByTextFormatName desc+    deleteField :: Set.Set String -> Parser.Field -> Set.Set String+    deleteField fs (Parser.Field (Parser.Key name) _) = Set.delete name fs+    deleteField fs (Parser.Field (Parser.UnknownKey n) _)+        | Just d <- Map.lookup (Tag (fromIntegral n)) $ fieldsByTag desc+        = Set.delete (fieldDescriptorName d) fs+    deleteField fs _ = fs+++buildMessageFromDescriptor+    :: MessageDescriptor msg -> msg -> Parser.Message -> Either String msg+buildMessageFromDescriptor descr = foldlM (addField descr)++addField :: MessageDescriptor msg -> msg -> Parser.Field -> Either String msg+addField descr msg (Parser.Field key rawValue) = do+    FieldDescriptor _ typeDescriptor accessor <- getFieldDescriptor+    value <- makeValue typeDescriptor rawValue+    return $ modifyField accessor value msg+  where+    getFieldDescriptor+        | Parser.Key name <- key, Just f <- Map.lookup name+                                                (fieldsByTextFormatName descr)+            = return f+        | Parser.UnknownKey tag <- key, Just f <- Map.lookup (fromIntegral tag)+                                                      (fieldsByTag descr)+            = return f+        | otherwise = Left $ "Unrecognized field " ++ show key++modifyField :: FieldAccessor msg value -> value -> msg -> msg+modifyField (PlainField _ f) value = set f value+modifyField (OptionalField f) value = set f (Just value)+modifyField (RepeatedField _ f) value = over f (value :)+modifyField (MapField key value f) mapElem+    = over f (Map.insert (mapElem ^. key) (mapElem ^. value))++makeValue :: FieldTypeDescriptor value -> Parser.Value -> Either String value+makeValue Int32Field (Parser.IntValue x) = Right (fromInteger x)+makeValue Int64Field (Parser.IntValue x) = Right (fromInteger x)+makeValue UInt32Field (Parser.IntValue x) = Right (fromInteger x)+makeValue UInt64Field (Parser.IntValue x) = Right (fromInteger x)+makeValue SInt32Field (Parser.IntValue x) = Right (fromInteger x)+makeValue SInt64Field (Parser.IntValue x) = Right (fromInteger x)+makeValue Fixed32Field (Parser.IntValue x) = Right (fromInteger x)+makeValue Fixed64Field (Parser.IntValue x) = Right (fromInteger x)+makeValue SFixed32Field (Parser.IntValue x) = Right (fromInteger x)+makeValue SFixed64Field (Parser.IntValue x) = Right (fromInteger x)+makeValue FloatField (Parser.IntValue x) = Right (fromInteger x)+makeValue DoubleField (Parser.IntValue x) = Right (fromInteger x)+makeValue BoolField (Parser.IntValue x)+    | x == 0 = Right False+    | x == 1 = Right True+    | otherwise = Left $ "Unrecognized bool value " ++ show x+makeValue DoubleField (Parser.DoubleValue x) = Right x+makeValue FloatField (Parser.DoubleValue x) = Right (realToFrac x)+makeValue BoolField (Parser.EnumValue x)+    | x == "true" = Right True+    | x == "false" = Right False+    | otherwise = Left $ "Unrecognized bool value " ++ show x+makeValue StringField (Parser.StringValue x) = Right (Text.pack x)+makeValue BytesField (Parser.StringValue x) = Right (B.pack x)+makeValue EnumField (Parser.IntValue x) =+    maybe (Left $ "Unrecognized enum value " ++ show x) Right+        (maybeToEnum $ fromInteger x)+makeValue EnumField (Parser.EnumValue x) =+    maybe (Left $ "Unrecognized enum value " ++ show x) Right+        (readEnum x)+makeValue MessageField (Parser.MessageValue x) = buildMessage x+makeValue GroupField (Parser.MessageValue x) = buildMessage x+makeValue f val = Left $ "Type mismatch parsing text format: " ++ show (f, val)
+ src/Data/ProtoLens/TextFormat/Parser.hs view
@@ -0,0 +1,103 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++-- | Helper utilities to parse the human-readable text format into a+-- proto-agnostic syntax tree.+module Data.ProtoLens.TextFormat.Parser+    ( Message+    , Field(..)+    , Key(..)+    , Value(..)+    , parser+    ) where++import Data.List (intercalate)+import Data.Functor.Identity (Identity)+import Data.Text.Lazy (Text)+import Text.Parsec.Char (alphaNum, char, letter, oneOf)+import Text.Parsec.Text.Lazy (Parser)+import Text.Parsec.Combinator (eof, sepBy1, many1, choice)+import Text.Parsec.Token+import Control.Applicative ((<*), (<|>), (*>), many)+import Control.Monad (liftM, liftM2, mzero)++-- | A 'TokenParser' for the protobuf text format.+ptp :: GenTokenParser Text () Identity+ptp = makeTokenParser protobufLangDef++protobufLangDef :: GenLanguageDef Text () Identity+-- We need to fill in the fields manually, since the LanguageDefs provided+-- by Parsec are restricted to parsers of Strings.+protobufLangDef = LanguageDef+  { commentStart = ""+  , commentEnd = ""+  , commentLine = "#"+  , nestedComments = False+  , identStart = letter <|> char '_'+  , identLetter = alphaNum <|> oneOf "_'"+  , opStart = mzero+  , opLetter = mzero+  , reservedNames = []+  , reservedOpNames = []+  , caseSensitive = True+  }+++type Message = [Field]++data Field = Field Key Value+  deriving (Show,Ord,Eq)++data Key = Key String  -- ^ A standard key that is just a string.+  | UnknownKey Integer  -- ^ A key that has been written out as a number+  | ExtensionKey [String]  -- ^ An extension, with namespaces and extension.+  | UnknownExtensionKey Integer  -- ^ An extension that has been written out+                                 -- as a number.+  deriving (Ord,Eq)++data Value = IntValue Integer  -- ^ An integer+  | DoubleValue Double  -- ^ Any floating point number+  | StringValue String  -- ^ A string literal+  | MessageValue Message  -- ^ A sub message+  | EnumValue String  -- ^ Any undelimited string (including false & true)+  deriving (Show,Ord,Eq)++instance Show Key+  where+    show (Key name) = name+    show (UnknownKey k) = show k+    show (ExtensionKey name) = "[" ++ intercalate "." name ++ "]"+    show (UnknownExtensionKey k) = "[" ++ show k ++ "]"++parser :: Parser Message+parser = whiteSpace ptp *> parseMessage <* eof+  where+    parseMessage = many parseField+    parseField = liftM2 Field parseKey parseValue+    parseKey =+        liftM Key (identifier ptp) <|>+        liftM UnknownKey (natural ptp) <|>+        liftM ExtensionKey (brackets ptp (identifier ptp `sepBy1` dot ptp)) <|>+        liftM UnknownExtensionKey (brackets ptp (natural ptp))+    parseValue =+        colon ptp *> choice+            [parseNumber, parseString, parseEnumValue, parseMessageValue] <|>+        parseMessageValue++    parseNumber = do+        negative <- (symbol ptp "-" >> return True) <|> return False+        value <- naturalOrFloat ptp+        return $ makeNumberValue negative value+    parseString = liftM (StringValue . concat) . many1 $ stringLiteral ptp+    parseEnumValue = liftM EnumValue (identifier ptp)+    parseMessageValue = liftM MessageValue+        (braces ptp parseMessage <|> angles ptp parseMessage)++    makeNumberValue :: Bool -> Either Integer Double -> Value+    makeNumberValue True (Left intValue) = IntValue (negate intValue)+    makeNumberValue False (Left intValue) = IntValue intValue+    makeNumberValue True (Right doubleValue) = DoubleValue (negate doubleValue)+    makeNumberValue False (Right doubleValue) = DoubleValue doubleValue