proto-lens-arbitrary (empty) → 0.1.0.0

raw patch · 4 files changed

+226/−0 lines, 4 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, lens-family, proto-lens, text

Files

LICENSE +30/−0
Setup.hs +2/−0
proto-lens-arbitrary.cabal +27/−0
src/Data/ProtoLens/Arbitrary.hs +167/−0

+ 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-arbitrary.cabal view

@@ -0,0 +1,27 @@+name:                proto-lens-arbitrary+version:             0.1.0.0+synopsis:            Arbitrary instances for proto-lens.+description:+  The proto-lens-arbitrary allows generating arbitrary messages for+  use with QuickCheck.++homepage:            https://github.com/google/proto-lens+license:             BSD3+license-file:        LICENSE+author:              Aden Grue+maintainer:          agrue+protolens@google.com+copyright:           Google Inc.+category:            Data+build-type:          Simple+cabal-version:       >=1.8++library+  hs-source-dirs: src+  exposed-modules:     Data.ProtoLens.Arbitrary+  build-depends:  proto-lens == 0.1.*+                , base == 4.8.*+                , bytestring == 0.10.*+                , containers == 0.5.*+                , text == 1.2.*+                , lens-family == 1.2.*+                , QuickCheck == 2.8.*

+ src/Data/ProtoLens/Arbitrary.hs view

@@ -0,0 +1,167 @@+-- 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 DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+-- | An Arbitrary instance for protocol buffer Messages to use with QuickCheck.+module Data.ProtoLens.Arbitrary+    ( ArbitraryMessage(..),+    ) where++import Data.ProtoLens.Message++import Control.Applicative ((<$>), pure)+import Control.Arrow ((&&&))+import Control.Monad (foldM)+import qualified Data.ByteString as BS+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (isJust, fromJust)+import qualified Data.Text as T+import Lens.Family2 (Lens', view, set)+import Lens.Family2.Unchecked (lens)+import Test.QuickCheck (Arbitrary(..), Gen, suchThat, frequency, listOf,+                        shrinkList)+++-- | A newtype wrapper that provides an Arbitrary instance for the underlying+-- message.+newtype ArbitraryMessage a =+    ArbitraryMessage { unArbitraryMessage :: a } deriving (Eq, Show, Functor)++instance Message a => Arbitrary (ArbitraryMessage a) where+    arbitrary = ArbitraryMessage <$> arbitraryMessage+    shrink (ArbitraryMessage a) = ArbitraryMessage <$> shrinkMessage a++arbitraryMessage :: Message a => Gen a+arbitraryMessage = foldM (flip arbitraryField) def fields+  where+    fields = M.elems (fieldsByTag descriptor)++-- | Imitation of the (Arbitrary a => Arbitrary (Maybe a)) instance from+-- QuickCheck.+maybeGen :: Gen a -> Gen (Maybe a)+maybeGen gen = frequency [ (1, pure Nothing), (3, Just <$> gen) ]++mapGen :: (Ord key, Message entry) => Lens' entry key -> Lens' entry value ->+          Gen entry -> Gen (Map key value)+mapGen keyLens valueLens entryGen =+    mapEntriesLens keyLens valueLens (const $ listOf entryGen) M.empty++setGen :: Lens' msg a -> Gen a -> msg -> Gen msg+setGen l gen = l (const gen)++arbitraryField :: FieldDescriptor msg -> msg -> Gen msg+arbitraryField (FieldDescriptor _ ftd fa) = case fa of+    PlainField _ l -> setGen l fieldGen+    OptionalField l -> setGen l (maybeGen fieldGen)+    RepeatedField _ l -> setGen l (listOf fieldGen)+    MapField keyLens valueLens mapLens ->+        setGen mapLens (mapGen keyLens valueLens fieldGen)+  where+    fieldGen = arbitraryFieldValue ftd++arbitraryFieldValue :: FieldTypeDescriptor value -> Gen value+arbitraryFieldValue ftd = case ftd of+    MessageField -> unArbitraryMessage <$> arbitrary+    GroupField -> unArbitraryMessage <$> arbitrary+    -- For enum fields, all we know is that the value is an instance of+    -- MessageEnum, meaning we can only use fromEnum, toEnum, or maybeToEnum. So+    -- we must rely on the instance of Arbitrary for Int and filter out only the+    -- cases that can actually be converted to one of the enum values.+    --+    -- 'fromJust' is okay here because 'suchThat' will ensure that all generated+    -- values are 'Just _'.+    EnumField -> fromJust <$> (maybeToEnum <$> arbitrary) `suchThat` isJust+    Int32Field -> arbitrary+    Int64Field -> arbitrary+    UInt32Field -> arbitrary+    UInt64Field -> arbitrary+    SInt32Field -> arbitrary+    SInt64Field -> arbitrary+    Fixed32Field -> arbitrary+    Fixed64Field -> arbitrary+    SFixed32Field -> arbitrary+    SFixed64Field -> arbitrary+    FloatField -> arbitrary+    DoubleField -> arbitrary+    BoolField -> arbitrary+    StringField -> T.pack <$> arbitrary+    BytesField -> BS.pack <$> arbitrary++-- | Shrink each field individually and append all shrinks together into+-- a single list.+shrinkMessage :: Message a => a -> [a]+shrinkMessage msg = concatMap (`shrinkField` msg) fields+  where+    fields = M.elems (fieldsByTag descriptor)++shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a]+shrinkMaybe f (Just v) = Nothing : (Just <$> f v)+shrinkMaybe _ Nothing  = []++shrinkMap :: (Ord key, Message entry) => Lens' entry key -> Lens' entry value+          -> (entry -> [entry]) -> Map key value -> [Map key value]+shrinkMap keyLens valueLens f = mapEntriesLens keyLens valueLens (shrinkList f)++shrinkField :: FieldDescriptor msg -> msg -> [msg]+shrinkField (FieldDescriptor _ ftd fa) = case fa of+    PlainField _ l -> l fieldShrinker+    OptionalField l -> l (shrinkMaybe fieldShrinker)+    RepeatedField _ l -> l (shrinkList fieldShrinker)+    MapField keyLens valueLens mapLens ->+        mapLens (shrinkMap keyLens valueLens fieldShrinker)+  where+    fieldShrinker = shrinkFieldValue ftd++shrinkFieldValue :: FieldTypeDescriptor value -> value -> [value]+shrinkFieldValue ftd = case ftd of+    MessageField -> map unArbitraryMessage . shrink . ArbitraryMessage+    GroupField -> map unArbitraryMessage . shrink . ArbitraryMessage+    -- Shrink to the 0-equivalent Enum value if it's both a valid Enum value+    -- and the value isn't already 0.+    EnumField -> case maybeToEnum 0 of+        Nothing -> const []+        Just zeroVal -> \val -> case fromEnum val of+          0 -> []+          _ -> [zeroVal]+    Int32Field -> shrink+    Int64Field -> shrink+    UInt32Field -> shrink+    UInt64Field -> shrink+    SInt32Field -> shrink+    SInt64Field -> shrink+    Fixed32Field -> shrink+    Fixed64Field -> shrink+    SFixed32Field -> shrink+    SFixed64Field -> shrink+    FloatField -> shrink+    DoubleField -> shrink+    BoolField -> shrink+    StringField -> map T.pack . shrink . T.unpack+    BytesField -> map BS.pack . shrink . BS.unpack++mapToEntries :: Message entry =>+                Lens' entry key -> Lens' entry value -> Map key value -> [entry]+mapToEntries keyLens valueLens m = makeEntry <$> M.toList m+  where+    makeEntry (k, v) = (set keyLens k . set valueLens v) def++entriesToMap :: Ord key =>+                Lens' entry key -> Lens' entry value -> [entry] -> Map key value+entriesToMap keyLens valueLens entries = M.fromList kvs+  where+    kvs = (view keyLens &&& view valueLens) <$> entries++-- This isn't a true lens because it doesn't obey the lens laws. Specifically,+-- view l (set l entries) /= entries because the input list of entries may+-- contain duplicate keys that would become de-duped inside the Map. It's only+-- included here to make it easy to convert from a list of entry Messages to+-- a Map.+mapEntriesLens :: (Ord key, Message entry) =>+        Lens' entry key -> Lens' entry value -> Lens' (Map key value) [entry]+mapEntriesLens kl vl = lens (mapToEntries kl vl) (const (entriesToMap kl vl))