summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTvH <>2018-11-21 15:50:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-11-21 15:50:00 (GMT)
commitc5a9e0f98fc08ccb2b5703361700cd8190696072 (patch)
tree46aa4e3ce88b5db8af145c92353a5c7a5589508c
parent0e79f5319e1f79369be78c421cfa6fb058814f7d (diff)
version 2.4.122.4.12
-rw-r--r--README.md2
-rw-r--r--Text/ProtocolBuffers.hs2
-rw-r--r--Text/ProtocolBuffers/Basic.hs15
-rw-r--r--Text/ProtocolBuffers/Extensions.hs3
-rw-r--r--Text/ProtocolBuffers/Get.hs15
-rw-r--r--Text/ProtocolBuffers/Header.hs22
-rw-r--r--Text/ProtocolBuffers/Identifiers.hs5
-rw-r--r--Text/ProtocolBuffers/ProtoJSON.hs45
-rw-r--r--Text/ProtocolBuffers/Reflections.hs2
-rw-r--r--Text/ProtocolBuffers/TextMessage.hs3
-rw-r--r--Text/ProtocolBuffers/Unknown.hs42
-rw-r--r--protocol-buffers.cabal13
12 files changed, 118 insertions, 51 deletions
diff --git a/README.md b/README.md
index 0096f56..da074b4 100644
--- a/README.md
+++ b/README.md
@@ -6,7 +6,7 @@ This the README file for `protocol-buffers`,
interdependent Haskell packages originally written by Chris Kuklewicz.
Currently, maintainership was taken by Timo von Holtz. It is
-planned to only support GHC 7.10 and newer unless someone explicitly
+planned to only support GHC 8.0 and newer unless someone explicitly
asks for support of earlier versions.
(Needs check) This README was updated most recently to reflect version
diff --git a/Text/ProtocolBuffers.hs b/Text/ProtocolBuffers.hs
index 9619784..a3982fe 100644
--- a/Text/ProtocolBuffers.hs
+++ b/Text/ProtocolBuffers.hs
@@ -47,6 +47,7 @@ module Text.ProtocolBuffers(
, module Text.ProtocolBuffers.Reflections
, module Text.ProtocolBuffers.TextMessage
, module Text.ProtocolBuffers.WireMessage
+ , module Text.ProtocolBuffers.ProtoJSON
) where
import Text.ProtocolBuffers.Basic
@@ -62,6 +63,7 @@ import Text.ProtocolBuffers.Reflections
, KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF )
import Text.ProtocolBuffers.TextMessage
( messagePutText, messageGetText )
+import Text.ProtocolBuffers.ProtoJSON
import Text.ProtocolBuffers.WireMessage
( Wire,Put,Get,runPut,runGet,runGetOnLazy
, messageSize,messagePut,messageGet,messagePutM,messageGetM
diff --git a/Text/ProtocolBuffers/Basic.hs b/Text/ProtocolBuffers/Basic.hs
index 88da387..3a405e5 100644
--- a/Text/ProtocolBuffers/Basic.hs
+++ b/Text/ProtocolBuffers/Basic.hs
@@ -13,6 +13,7 @@ module Text.ProtocolBuffers.Basic
, isValidUTF8, toUtf8, utf8, uToString, uFromString
) where
+import Data.Aeson
import Data.Bits(Bits)
import Data.ByteString.Lazy(ByteString)
import Data.Foldable as F(Foldable(foldl))
@@ -20,15 +21,14 @@ import Data.Generics(Data(..))
import Data.Int(Int32,Int64)
import Data.Ix(Ix)
import Data.Semigroup (Semigroup(..))
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid(Monoid(..))
-#endif
import Data.Sequence(Seq,(><))
import Data.Typeable(Typeable)
import Data.Word(Word8,Word32,Word64)
import qualified Data.ByteString.Lazy as L(unpack)
import Data.ByteString.Lazy.UTF8 as U (toString,fromString)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
-- Num instances are derived below for the purpose of getting fromInteger for case matching
@@ -59,6 +59,15 @@ instance Monoid Utf8 where
mempty = Utf8 mempty
mappend = (<>)
+instance ToJSON Utf8 where
+ toJSON (Utf8 t) = toJSON (TL.decodeUtf8 t)
+
+instance FromJSON Utf8 where
+ parseJSON value =
+ case value of
+ String t -> return . Utf8 . TL.encodeUtf8 . TL.fromStrict $ t
+ _ -> fail ("Value " ++ show value ++ " is not a UTF-8 string")
+
-- | 'WireTag' is the 32 bit value with the upper 29 bits being the
-- 'FieldId' and the lower 3 bits being the 'WireType'
newtype WireTag = WireTag { getWireTag :: Word32 } -- bit concatenation of FieldId and WireType
diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs
index 96bf5fb..fca402b 100644
--- a/Text/ProtocolBuffers/Extensions.hs
+++ b/Text/ProtocolBuffers/Extensions.hs
@@ -35,9 +35,6 @@ import qualified Data.Foldable as F
import Data.Map(Map)
import qualified Data.Map as M
import Data.Maybe(fromMaybe,isJust)
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid(mappend,mconcat)
-#endif
import Data.Sequence((|>),(><),viewl,ViewL(..))
import qualified Data.Sequence as Seq(singleton,null,empty)
import Data.Typeable(Typeable,typeOf,cast)
diff --git a/Text/ProtocolBuffers/Get.hs b/Text/ProtocolBuffers/Get.hs
index 82f6c16..c9e878c 100644
--- a/Text/ProtocolBuffers/Get.hs
+++ b/Text/ProtocolBuffers/Get.hs
@@ -65,11 +65,7 @@ module Text.ProtocolBuffers.Get
-- The Get monad is an instance of binary-strict's BinaryParser:
-- import qualified Data.Binary.Strict.Class as P(BinaryParser(..))
-- The Get monad is an instance of all of these library classes:
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative(Applicative(pure,(<*>)),Alternative(empty,(<|>)))
-#else
import Control.Applicative(Alternative(empty,(<|>)))
-#endif
import Control.Monad(MonadPlus(mzero,mplus),when)
import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg))
-- It can be a MonadCont, but the semantics are too broken without a ton of work.
@@ -87,12 +83,7 @@ import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromCh
import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk)
import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq
import Data.Int(Int32,Int64) -- index type for L.ByteString
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid(Monoid(mempty,mappend)) -- Writer has a Monoid contraint
-import Data.Word(Word,Word8,Word16,Word32,Word64)
-#else
import Data.Word(Word8,Word16,Word32,Word64)
-#endif
import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state
import Foreign.ForeignPtr(withForeignPtr)
import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr,nullPtr)
@@ -871,12 +862,6 @@ shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
#if WORD_SIZE_IN_BITS < 64
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
-#if __GLASGOW_HASKELL__ <= 606
--- Exported by GHC.Word in GHC 6.8 and higher
-foreign import ccall unsafe "stg_uncheckedShiftL64"
- uncheckedShiftL64# :: Word64# -> Int# -> Word64#
-#endif
-
#else
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
#endif
diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs
index 2add57a..e35bc0a 100644
--- a/Text/ProtocolBuffers/Header.hs
+++ b/Text/ProtocolBuffers/Header.hs
@@ -4,9 +4,14 @@
module Text.ProtocolBuffers.Header
( append, emptyBS
, pack, fromMaybe, ap
+ , msum
, fromDistinctAscList, member
, throwError,catchError
, choice, sepEndBy, spaces, try
+ , (<=<)
+ , FromJSON(..), ToJSON(..)
+ , Value(..)
+ , explicitParseField, explicitParseFieldMaybe, withObject, withText
, module Data.Generics
, module Text.ProtocolBuffers.Basic
, module Text.ProtocolBuffers.Extensions
@@ -15,10 +20,13 @@ module Text.ProtocolBuffers.Header
, module Text.ProtocolBuffers.TextMessage
, module Text.ProtocolBuffers.Unknown
, module Text.ProtocolBuffers.WireMessage
+ , module Text.ProtocolBuffers.ProtoJSON
) where
-import Control.Monad(ap)
+import Control.Monad(ap, (<=<), msum)
import Control.Monad.Error.Class(throwError,catchError)
+import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))
+import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe, withObject, withText)
import Data.ByteString.Lazy(empty)
import Data.ByteString.Lazy.Char8(pack)
import Data.Generics(Data(..))
@@ -39,7 +47,16 @@ import Text.ProtocolBuffers.Reflections
, GetMessageInfo(GetMessageInfo),DescriptorInfo(extRanges),makePNF )
import Text.ProtocolBuffers.TextMessage -- all
import Text.ProtocolBuffers.Unknown
- ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,wirePutUnknownFieldWithSize,catch'Unknown )
+ ( UnknownField
+ , UnknownMessage(..)
+ , wireSizeUnknownField
+ , wirePutUnknownField
+ , wirePutUnknownFieldWithSize
+ , catch'Unknown
+ , catch'Unknown'
+ , loadUnknown
+ , discardUnknown
+ )
import Text.ProtocolBuffers.WireMessage
( Wire(..)
, prependMessageSize,putSize,splitWireTag
@@ -53,6 +70,7 @@ import Text.ProtocolBuffers.WireMessage
, wireSizeErr,wirePutErr,wireGetErr,size'WireSize
, unknown,unknownField
, fieldIdOf)
+import Text.ProtocolBuffers.ProtoJSON
{-# INLINE append #-}
append :: Seq a -> a -> Seq a
diff --git a/Text/ProtocolBuffers/Identifiers.hs b/Text/ProtocolBuffers/Identifiers.hs
index 1aa2f46..7e40f8e 100644
--- a/Text/ProtocolBuffers/Identifiers.hs
+++ b/Text/ProtocolBuffers/Identifiers.hs
@@ -30,12 +30,7 @@ module Text.ProtocolBuffers.Identifiers
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Lazy.UTF8 as U
import Data.Char
-#if __GLASGOW_HASKELL__ < 710
-import Data.List
-import Data.Monoid
-#else
import Data.List hiding (uncons)
-#endif
import Data.Generics(Data)
import Data.Typeable(Typeable)
import Data.Set(Set)
diff --git a/Text/ProtocolBuffers/ProtoJSON.hs b/Text/ProtocolBuffers/ProtoJSON.hs
new file mode 100644
index 0000000..f2bac19
--- /dev/null
+++ b/Text/ProtocolBuffers/ProtoJSON.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Werror #-}
+module Text.ProtocolBuffers.ProtoJSON where
+
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.Vector as V
+import Text.ProtocolBuffers.Basic
+import Text.Read (readEither)
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.Text.Encoding as T
+
+objectNoEmpty :: [Pair] -> Value
+objectNoEmpty = object . filter (hasContent . snd)
+ where
+ hasContent Null = False
+ hasContent (Array xs) | V.null xs = False
+ hasContent _ = True
+
+toJSONShowWithPayload :: Show a => a -> Value
+toJSONShowWithPayload x = object [("payload", toJSON . show $ x)]
+
+parseJSONReadWithPayload :: Read a => String -> Value -> Parser a
+parseJSONReadWithPayload tyName = withObject tyName $ \o -> do
+ t <- o .: "payload"
+ case readEither t of
+ Left e -> fail e
+ Right res -> return res
+
+parseJSONBool :: Value -> Parser Bool
+parseJSONBool (Bool b) = return b
+parseJSONBool (Number sci) = return (sci >= 1)
+parseJSONBool _ = fail "Expected Bool"
+
+toJSONByteString :: ByteString -> Value
+toJSONByteString bs = object [("payload", String . T.decodeUtf8 . B16.encode . BL.toStrict $ bs)]
+
+parseJSONByteString :: Value -> Parser ByteString
+parseJSONByteString = withObject "bytes" $ \o -> do
+ t <- o .: "payload"
+ case B16.decode (T.encodeUtf8 t) of
+ (bs, "") -> return (BL.fromStrict bs)
+ _ -> fail "Failed to parse base16."
diff --git a/Text/ProtocolBuffers/Reflections.hs b/Text/ProtocolBuffers/Reflections.hs
index 714de06..a443ceb 100644
--- a/Text/ProtocolBuffers/Reflections.hs
+++ b/Text/ProtocolBuffers/Reflections.hs
@@ -82,6 +82,7 @@ data DescriptorInfo = DescriptorInfo { descName :: ProtoName
, storeUnknown :: Bool
, lazyFields :: Bool
, makeLenses :: Bool
+ , jsonInstances :: Bool
}
deriving (Show,Read,Eq,Ord,Data,Typeable)
@@ -160,6 +161,7 @@ data OneofInfo = OneofInfo { oneofName :: ProtoName
data EnumInfo = EnumInfo { enumName :: ProtoName
, enumFilePath :: [FilePath]
, enumValues :: [(EnumCode,String)] -- ^ The String is the Haskell name to write into the generated source files
+ , enumJsonInstances :: Bool
}
deriving (Show,Read,Eq,Ord,Data,Typeable)
diff --git a/Text/ProtocolBuffers/TextMessage.hs b/Text/ProtocolBuffers/TextMessage.hs
index 43a2210..9dc908b 100644
--- a/Text/ProtocolBuffers/TextMessage.hs
+++ b/Text/ProtocolBuffers/TextMessage.hs
@@ -13,9 +13,6 @@ module Text.ProtocolBuffers.TextMessage (
getSubMessage,
) where
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative ((<$>), (<*), (*>))
-#endif
import Control.Monad.Identity (Identity)
import Control.Monad (void)
import Control.Monad.Writer (Writer, execWriter, tell, censor)
diff --git a/Text/ProtocolBuffers/Unknown.hs b/Text/ProtocolBuffers/Unknown.hs
index 0e6555e..c3c996f 100644
--- a/Text/ProtocolBuffers/Unknown.hs
+++ b/Text/ProtocolBuffers/Unknown.hs
@@ -4,15 +4,13 @@
-- notice. Importer beware.
module Text.ProtocolBuffers.Unknown
( UnknownField(..),UnknownMessage(..),UnknownFieldValue(..)
- , wireSizeUnknownField,wirePutUnknownField, wirePutUnknownFieldWithSize,catch'Unknown
+ , wireSizeUnknownField,wirePutUnknownField, wirePutUnknownFieldWithSize
+ , catch'Unknown, catch'Unknown', loadUnknown, discardUnknown
) where
import qualified Data.ByteString.Lazy as L
import qualified Data.Foldable as F
import Data.Generics
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid(mempty,mappend)
-#endif
import Data.Sequence((|>))
import Data.Typeable()
import Control.Monad.Error.Class(catchError)
@@ -59,14 +57,30 @@ wirePutUnknownFieldWithSize m =
wirePutUnknownField m >> return (wireSizeUnknownField m)
{-# INLINE catch'Unknown #-}
+-- | This is used by the generated code. Here for backwards compatibility.
+catch'Unknown :: (UnknownMessage a) => (WireTag -> a -> Get a) -> WireTag -> a -> Get a
+catch'Unknown = catch'Unknown' loadUnknown
+
+{-# INLINE catch'Unknown' #-}
+catch'Unknown' :: (WireTag -> a -> Get a) -> (WireTag -> a -> Get a) -> WireTag -> a -> Get a
+catch'Unknown' handleUnknown update'Self wire'Tag old'Self =
+ catchError (update'Self wire'Tag old'Self) (\_ -> handleUnknown wire'Tag old'Self)
+
+{-# INLINE loadUnknown #-}
+-- | This is used by the generated code
+loadUnknown :: (UnknownMessage a) => WireTag -> a -> Get a
+loadUnknown tag msg = do
+ let (fieldId,wireType) = splitWireTag tag
+ (UnknownField uf) = getUnknownField msg
+ bs <- wireGetFromWire fieldId wireType
+ let v' = seq bs $ UFV tag bs
+ uf' = seq v' $ uf |> v'
+ seq uf' $ return $ putUnknownField (UnknownField uf') msg
+
+{-# INLINE discardUnknown #-}
-- | This is used by the generated code
-catch'Unknown :: (Typeable a, UnknownMessage a) => (WireTag -> a -> Get a) -> (WireTag -> a -> Get a)
-catch'Unknown update'Self = \wire'Tag old'Self -> catchError (update'Self wire'Tag old'Self) (\_ -> loadUnknown wire'Tag old'Self)
- where loadUnknown :: (Typeable a, UnknownMessage a) => WireTag -> a -> Get a
- loadUnknown tag msg = do
- let (fieldId,wireType) = splitWireTag tag
- (UnknownField uf) = getUnknownField msg
- bs <- wireGetFromWire fieldId wireType
- let v' = seq bs $ UFV tag bs
- uf' = seq v' $ uf |> v'
- seq uf' $ return $ putUnknownField (UnknownField uf') msg
+discardUnknown :: WireTag -> a -> Get a
+discardUnknown tag msg = do
+ let (fieldId,wireType) = splitWireTag tag
+ _bs <- wireGetFromWire fieldId wireType
+ return msg
diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal
index a5eff68..0ff6763 100644
--- a/protocol-buffers.cabal
+++ b/protocol-buffers.cabal
@@ -1,5 +1,5 @@
name: protocol-buffers
-version: 2.4.11
+version: 2.4.12
cabal-version: >= 1.6
build-type: Simple
license: BSD3
@@ -14,6 +14,7 @@ description: Parse proto files and generate Haskell code.
category: Text
extra-source-files: TODO
README.md
+Tested-With: GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.2, GHC == 8.6.2
source-repository head
type: git
location: git://github.com/k-bx/protocol-buffers.git
@@ -32,21 +33,23 @@ Library
Text.ProtocolBuffers.TextMessage
Text.ProtocolBuffers.Unknown
Text.ProtocolBuffers.WireMessage
+ Text.ProtocolBuffers.ProtoJSON
- build-depends: base >= 4.7.0 && < 5,
+ build-depends: base >= 4.9.0 && < 5,
+ aeson >= 1.1.0.0,
array,
+ base16-bytestring,
+ text,
binary,
bytestring,
containers,
directory,
filepath,
mtl,
+ vector,
parsec,
utf8-string,
syb
- if !impl(ghc >= 8.0)
- build-depends:
- semigroups >= 0.11 && < 0.19
-- Most of these are needed for protocol-buffers (Get and WireMessage.hs)
-- Nothing especially hazardous in this list