-- 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 LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
-- | An Arbitrary instance for protocol buffer Messages to use with QuickCheck.
module Data.ProtoLens.Arbitrary
    ( ArbitraryMessage(..)
    , arbitraryMessage
    , shrinkMessage
    ) where

import Data.ProtoLens.Message

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, scale)


-- | A newtype wrapper that provides an Arbitrary instance for the underlying
-- message.
newtype ArbitraryMessage a =
    ArbitraryMessage { forall a. ArbitraryMessage a -> a
unArbitraryMessage :: a } deriving (ArbitraryMessage a -> ArbitraryMessage a -> Bool
(ArbitraryMessage a -> ArbitraryMessage a -> Bool)
-> (ArbitraryMessage a -> ArbitraryMessage a -> Bool)
-> Eq (ArbitraryMessage a)
forall a. Eq a => ArbitraryMessage a -> ArbitraryMessage a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ArbitraryMessage a -> ArbitraryMessage a -> Bool
== :: ArbitraryMessage a -> ArbitraryMessage a -> Bool
$c/= :: forall a. Eq a => ArbitraryMessage a -> ArbitraryMessage a -> Bool
/= :: ArbitraryMessage a -> ArbitraryMessage a -> Bool
Eq, Int -> ArbitraryMessage a -> ShowS
[ArbitraryMessage a] -> ShowS
ArbitraryMessage a -> String
(Int -> ArbitraryMessage a -> ShowS)
-> (ArbitraryMessage a -> String)
-> ([ArbitraryMessage a] -> ShowS)
-> Show (ArbitraryMessage a)
forall a. Show a => Int -> ArbitraryMessage a -> ShowS
forall a. Show a => [ArbitraryMessage a] -> ShowS
forall a. Show a => ArbitraryMessage a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ArbitraryMessage a -> ShowS
showsPrec :: Int -> ArbitraryMessage a -> ShowS
$cshow :: forall a. Show a => ArbitraryMessage a -> String
show :: ArbitraryMessage a -> String
$cshowList :: forall a. Show a => [ArbitraryMessage a] -> ShowS
showList :: [ArbitraryMessage a] -> ShowS
Show, (forall a b. (a -> b) -> ArbitraryMessage a -> ArbitraryMessage b)
-> (forall a b. a -> ArbitraryMessage b -> ArbitraryMessage a)
-> Functor ArbitraryMessage
forall a b. a -> ArbitraryMessage b -> ArbitraryMessage a
forall a b. (a -> b) -> ArbitraryMessage a -> ArbitraryMessage b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ArbitraryMessage a -> ArbitraryMessage b
fmap :: forall a b. (a -> b) -> ArbitraryMessage a -> ArbitraryMessage b
$c<$ :: forall a b. a -> ArbitraryMessage b -> ArbitraryMessage a
<$ :: forall a b. a -> ArbitraryMessage b -> ArbitraryMessage a
Functor)

instance Message a => Arbitrary (ArbitraryMessage a) where
    arbitrary :: Gen (ArbitraryMessage a)
arbitrary = a -> ArbitraryMessage a
forall a. a -> ArbitraryMessage a
ArbitraryMessage (a -> ArbitraryMessage a) -> Gen a -> Gen (ArbitraryMessage a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Message a => Gen a
arbitraryMessage
    shrink :: ArbitraryMessage a -> [ArbitraryMessage a]
shrink (ArbitraryMessage a
a) = a -> ArbitraryMessage a
forall a. a -> ArbitraryMessage a
ArbitraryMessage (a -> ArbitraryMessage a) -> [a] -> [ArbitraryMessage a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
forall a. Message a => a -> [a]
shrinkMessage a
a

arbitraryMessage :: Message a => Gen a
arbitraryMessage :: forall a. Message a => Gen a
arbitraryMessage = (a -> FieldDescriptor a -> Gen a)
-> a -> [FieldDescriptor a] -> Gen a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((FieldDescriptor a -> a -> Gen a)
-> a -> FieldDescriptor a -> Gen a
forall a b c. (a -> b -> c) -> b -> a -> c
flip FieldDescriptor a -> a -> Gen a
forall msg. FieldDescriptor msg -> msg -> Gen msg
arbitraryField) a
forall msg. Message msg => msg
defMessage [FieldDescriptor a]
forall msg. Message msg => [FieldDescriptor msg]
allFields

-- | Imitation of the (Arbitrary a => Arbitrary (Maybe a)) instance from
-- QuickCheck.
maybeGen :: Gen a -> Gen (Maybe a)
maybeGen :: forall a. Gen a -> Gen (Maybe a)
maybeGen Gen a
gen = [(Int, Gen (Maybe a))] -> Gen (Maybe a)
forall a. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing), (Int
3, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Gen a -> Gen (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
gen) ]

mapGen :: (Ord key, Message entry) => Lens' entry key -> Lens' entry value ->
          Gen entry -> Gen (Map key value)
mapGen :: forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value -> Gen entry -> Gen (Map key value)
mapGen Lens' entry key
keyLens Lens' entry value
valueLens Gen entry
entryGen =
    Lens' entry key
-> Lens' entry value -> Lens' (Map key value) [entry]
forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value -> Lens' (Map key value) [entry]
mapEntriesLens LensLike' f entry key
Lens' entry key
keyLens LensLike' f entry value
Lens' entry value
valueLens (Gen [entry] -> [entry] -> Gen [entry]
forall a b. a -> b -> a
const (Gen [entry] -> [entry] -> Gen [entry])
-> Gen [entry] -> [entry] -> Gen [entry]
forall a b. (a -> b) -> a -> b
$ Gen entry -> Gen [entry]
forall a. Gen a -> Gen [a]
listOf Gen entry
entryGen) Map key value
forall k a. Map k a
M.empty

setGen :: Lens' msg a -> Gen a -> msg -> Gen msg
setGen :: forall msg a. Lens' msg a -> Gen a -> msg -> Gen msg
setGen Lens' msg a
l Gen a
gen = LensLike' Gen msg a
Lens' msg a
l (Gen a -> a -> Gen a
forall a b. a -> b -> a
const Gen a
gen)

arbitraryField :: FieldDescriptor msg -> msg -> Gen msg
arbitraryField :: forall msg. FieldDescriptor msg -> msg -> Gen msg
arbitraryField (FieldDescriptor String
_ FieldTypeDescriptor value
ftd FieldAccessor msg value
fa) = case FieldAccessor msg value
fa of
    PlainField WireDefault value
_ Lens' msg value
l -> Lens' msg value -> Gen value -> msg -> Gen msg
forall msg a. Lens' msg a -> Gen a -> msg -> Gen msg
setGen LensLike' f msg value
Lens' msg value
l Gen value
fieldGen
    OptionalField Lens' msg (Maybe value)
l -> Lens' msg (Maybe value) -> Gen (Maybe value) -> msg -> Gen msg
forall msg a. Lens' msg a -> Gen a -> msg -> Gen msg
setGen LensLike' f msg (Maybe value)
Lens' msg (Maybe value)
l (Gen value -> Gen (Maybe value)
forall a. Gen a -> Gen (Maybe a)
maybeGen Gen value
fieldGen)
    RepeatedField Packing
_ Lens' msg [value]
l -> Lens' msg [value] -> Gen [value] -> msg -> Gen msg
forall msg a. Lens' msg a -> Gen a -> msg -> Gen msg
setGen LensLike' f msg [value]
Lens' msg [value]
l (Gen value -> Gen [value]
forall a. Gen a -> Gen [a]
listOf Gen value
fieldGen)
    MapField Lens' value key
keyLens Lens' value value1
valueLens Lens' msg (Map key value1)
mapLens ->
        Lens' msg (Map key value1)
-> Gen (Map key value1) -> msg -> Gen msg
forall msg a. Lens' msg a -> Gen a -> msg -> Gen msg
setGen LensLike' f msg (Map key value1)
Lens' msg (Map key value1)
mapLens (Lens' value key
-> Lens' value value1 -> Gen value -> Gen (Map key value1)
forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value -> Gen entry -> Gen (Map key value)
mapGen LensLike' f value key
Lens' value key
keyLens LensLike' f value value1
Lens' value value1
valueLens Gen value
fieldGen)
  where
    fieldGen :: Gen value
fieldGen = FieldTypeDescriptor value -> Gen value
forall value. FieldTypeDescriptor value -> Gen value
arbitraryFieldValue FieldTypeDescriptor value
ftd

arbitraryFieldValue :: FieldTypeDescriptor value -> Gen value
arbitraryFieldValue :: forall value. FieldTypeDescriptor value -> Gen value
arbitraryFieldValue = \case
    MessageField MessageOrGroup
_ -> (Int -> Int) -> Gen value -> Gen value
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Gen value
forall a. Message a => Gen a
arbitraryMessage
    ScalarField ScalarField value
f -> ScalarField value -> Gen value
forall value. ScalarField value -> Gen value
arbitraryScalarValue ScalarField value
f

arbitraryScalarValue :: ScalarField value -> Gen value
arbitraryScalarValue :: forall value. ScalarField value -> Gen value
arbitraryScalarValue = \case
    -- 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 _'.
    ScalarField value
EnumField -> Maybe value -> value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe value -> value) -> Gen (Maybe value) -> Gen value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Maybe value
forall a. MessageEnum a => Int -> Maybe a
maybeToEnum (Int -> Maybe value) -> Gen Int -> Gen (Maybe value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary) Gen (Maybe value) -> (Maybe value -> Bool) -> Gen (Maybe value)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Maybe value -> Bool
forall a. Maybe a -> Bool
isJust
    ScalarField value
Int32Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
Int64Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
UInt32Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
UInt64Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
SInt32Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
SInt64Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
Fixed32Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
Fixed64Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
SFixed32Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
SFixed64Field -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
FloatField -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
DoubleField -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
BoolField -> Gen value
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
StringField -> String -> value
String -> Text
T.pack (String -> value) -> Gen String -> Gen value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
forall a. Arbitrary a => Gen a
arbitrary
    ScalarField value
BytesField -> [Word8] -> value
[Word8] -> ByteString
BS.pack ([Word8] -> value) -> Gen [Word8] -> Gen value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Word8]
forall a. Arbitrary a => Gen a
arbitrary

-- | Shrink each field individually and append all shrinks together into
-- a single list.
shrinkMessage :: Message a => a -> [a]
shrinkMessage :: forall a. Message a => a -> [a]
shrinkMessage a
msg = (FieldDescriptor a -> [a]) -> [FieldDescriptor a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FieldDescriptor a -> a -> [a]
forall msg. FieldDescriptor msg -> msg -> [msg]
`shrinkField` a
msg) [FieldDescriptor a]
forall msg. Message msg => [FieldDescriptor msg]
allFields

shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a]
shrinkMaybe :: forall a. (a -> [a]) -> Maybe a -> [Maybe a]
shrinkMaybe a -> [a]
f (Just a
v) = Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> [a] -> [Maybe a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
f a
v)
shrinkMaybe a -> [a]
_ Maybe a
Nothing  = []

shrinkMap :: (Ord key, Message entry) => Lens' entry key -> Lens' entry value
          -> (entry -> [entry]) -> Map key value -> [Map key value]
shrinkMap :: forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value
-> (entry -> [entry])
-> Map key value
-> [Map key value]
shrinkMap Lens' entry key
keyLens Lens' entry value
valueLens entry -> [entry]
f = Lens' entry key
-> Lens' entry value -> Lens' (Map key value) [entry]
forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value -> Lens' (Map key value) [entry]
mapEntriesLens LensLike' f entry key
Lens' entry key
keyLens LensLike' f entry value
Lens' entry value
valueLens ((entry -> [entry]) -> [entry] -> [[entry]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList entry -> [entry]
f')
  where
    f' :: entry -> [entry]
f' = (entry -> Bool) -> [entry] -> [entry]
forall a. (a -> Bool) -> [a] -> [a]
filter entry -> Bool
forall {msg}. Message msg => msg -> Bool
allFieldsAreSet ([entry] -> [entry]) -> (entry -> [entry]) -> entry -> [entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. entry -> [entry]
f
    -- Strip out all entries whose key or value is not set (and which distinguish
    -- between being unset and being the default value (proto2, or in proto3 for a
    -- message value type).
    -- The representation in the Map (as, effectively, a pair of key and value)
    -- does not distinguish between unset/default values.  This can lead to
    -- shrinkMap behaving incorrectly; for example,
    -- `Map.singleton 0 "abc"` gets represented as
    -- `[defMessage & #maybe'key .~ Just 0 & #value .~ "abc"]`, which might be
    -- shrunk to `[defMessage & #maybe'key .~ Nothing & #value .~ "abc"]`,
    -- which maps back to the same Map representation.
    -- Work around this for now by just filtering out entries with unset
    -- optional fields.
    allFieldsAreSet :: msg -> Bool
allFieldsAreSet msg
msg = (FieldDescriptor msg -> Bool) -> [FieldDescriptor msg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (msg -> FieldDescriptor msg -> Bool
forall {msg}. msg -> FieldDescriptor msg -> Bool
fieldIsSet msg
msg) [FieldDescriptor msg]
forall msg. Message msg => [FieldDescriptor msg]
allFields
    fieldIsSet :: msg -> FieldDescriptor msg -> Bool
fieldIsSet msg
msg (FieldDescriptor String
_ FieldTypeDescriptor value
_ (OptionalField Lens' msg (Maybe value)
l)) = Maybe value -> Bool
forall a. Maybe a -> Bool
isJust (FoldLike (Maybe value) msg msg (Maybe value) (Maybe value)
-> msg -> Maybe value
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike (Maybe value) msg msg (Maybe value) (Maybe value)
Lens' msg (Maybe value)
l msg
msg)
    fieldIsSet msg
_ FieldDescriptor msg
_ = Bool
True

shrinkField :: FieldDescriptor msg -> msg -> [msg]
shrinkField :: forall msg. FieldDescriptor msg -> msg -> [msg]
shrinkField (FieldDescriptor String
_ FieldTypeDescriptor value
ftd FieldAccessor msg value
fa) = case FieldAccessor msg value
fa of
    PlainField WireDefault value
_ Lens' msg value
l -> LensLike' [] msg value
Lens' msg value
l value -> [value]
fieldShrinker
    OptionalField Lens' msg (Maybe value)
l -> LensLike' [] msg (Maybe value)
Lens' msg (Maybe value)
l ((value -> [value]) -> Maybe value -> [Maybe value]
forall a. (a -> [a]) -> Maybe a -> [Maybe a]
shrinkMaybe value -> [value]
fieldShrinker)
    RepeatedField Packing
_ Lens' msg [value]
l -> LensLike' [] msg [value]
Lens' msg [value]
l ((value -> [value]) -> [value] -> [[value]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList value -> [value]
fieldShrinker)
    MapField Lens' value key
keyLens Lens' value value1
valueLens Lens' msg (Map key value1)
mapLens ->
        LensLike' [] msg (Map key value1)
Lens' msg (Map key value1)
mapLens (Lens' value key
-> Lens' value value1
-> (value -> [value])
-> Map key value1
-> [Map key value1]
forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value
-> (entry -> [entry])
-> Map key value
-> [Map key value]
shrinkMap LensLike' f value key
Lens' value key
keyLens LensLike' f value value1
Lens' value value1
valueLens value -> [value]
fieldShrinker)
  where
    fieldShrinker :: value -> [value]
fieldShrinker = FieldTypeDescriptor value -> value -> [value]
forall value. FieldTypeDescriptor value -> value -> [value]
shrinkFieldValue FieldTypeDescriptor value
ftd

shrinkFieldValue :: FieldTypeDescriptor value -> value -> [value]
shrinkFieldValue :: forall value. FieldTypeDescriptor value -> value -> [value]
shrinkFieldValue = \case
    MessageField MessageOrGroup
_ -> value -> [value]
forall a. Message a => a -> [a]
shrinkMessage
    ScalarField ScalarField value
f -> ScalarField value -> value -> [value]
forall value. ScalarField value -> value -> [value]
shrinkScalarValue ScalarField value
f

shrinkScalarValue :: ScalarField value -> value -> [value]
shrinkScalarValue :: forall value. ScalarField value -> value -> [value]
shrinkScalarValue = \case
    -- Shrink to the 0-equivalent Enum value if it's both a valid Enum value
    -- and the value isn't already 0.
    ScalarField value
EnumField -> case Int -> Maybe value
forall a. MessageEnum a => Int -> Maybe a
maybeToEnum Int
0 of
        Maybe value
Nothing -> [value] -> value -> [value]
forall a b. a -> b -> a
const []
        Just value
zeroVal -> \value
val -> case value -> Int
forall a. Enum a => a -> Int
fromEnum value
val of
          Int
0 -> []
          Int
_ -> [value
zeroVal]
    ScalarField value
Int32Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
Int64Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
UInt32Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
UInt64Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
SInt32Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
SInt64Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
Fixed32Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
Fixed64Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
SFixed32Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
SFixed64Field -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
FloatField -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
DoubleField -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
BoolField -> value -> [value]
forall a. Arbitrary a => a -> [a]
shrink
    ScalarField value
StringField -> (String -> value) -> [String] -> [value]
forall a b. (a -> b) -> [a] -> [b]
map String -> value
String -> Text
T.pack ([String] -> [value]) -> (value -> [String]) -> value -> [value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. Arbitrary a => a -> [a]
shrink (String -> [String]) -> (value -> String) -> value -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. value -> String
Text -> String
T.unpack
    ScalarField value
BytesField -> ([Word8] -> value) -> [[Word8]] -> [value]
forall a b. (a -> b) -> [a] -> [b]
map [Word8] -> value
[Word8] -> ByteString
BS.pack ([[Word8]] -> [value]) -> (value -> [[Word8]]) -> value -> [value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [[Word8]]
forall a. Arbitrary a => a -> [a]
shrink ([Word8] -> [[Word8]]) -> (value -> [Word8]) -> value -> [[Word8]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. value -> [Word8]
ByteString -> [Word8]
BS.unpack

mapToEntries :: Message entry =>
                Lens' entry key -> Lens' entry value -> Map key value -> [entry]
mapToEntries :: forall entry key value.
Message entry =>
Lens' entry key -> Lens' entry value -> Map key value -> [entry]
mapToEntries Lens' entry key
keyLens Lens' entry value
valueLens Map key value
m = (key, value) -> entry
makeEntry ((key, value) -> entry) -> [(key, value)] -> [entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map key value -> [(key, value)]
forall k a. Map k a -> [(k, a)]
M.toList Map key value
m
  where
    makeEntry :: (key, value) -> entry
makeEntry (key
k, value
v) = (Setter entry entry key key -> key -> entry -> entry
forall s t a b. Setter s t a b -> b -> s -> t
set LensLike' f entry key
Lens' entry key
Setter entry entry key key
keyLens key
k (entry -> entry) -> (entry -> entry) -> entry -> entry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setter entry entry value value -> value -> entry -> entry
forall s t a b. Setter s t a b -> b -> s -> t
set LensLike' f entry value
Lens' entry value
Setter entry entry value value
valueLens value
v) entry
forall msg. Message msg => msg
defMessage

entriesToMap :: Ord key =>
                Lens' entry key -> Lens' entry value -> [entry] -> Map key value
entriesToMap :: forall key entry value.
Ord key =>
Lens' entry key -> Lens' entry value -> [entry] -> Map key value
entriesToMap Lens' entry key
keyLens Lens' entry value
valueLens [entry]
entries = [(key, value)] -> Map key value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(key, value)]
kvs
  where
    kvs :: [(key, value)]
kvs = (FoldLike key entry entry key key -> entry -> key
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike key entry entry key key
Lens' entry key
keyLens (entry -> key) -> (entry -> value) -> entry -> (key, value)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& FoldLike value entry entry value value -> entry -> value
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike value entry entry value value
Lens' entry value
valueLens) (entry -> (key, value)) -> [entry] -> [(key, value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [entry]
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.
-- See the comment in shrinkMap for why this is a problem.
-- TODO: consider a different Message representation for maps.
mapEntriesLens :: (Ord key, Message entry) =>
        Lens' entry key -> Lens' entry value -> Lens' (Map key value) [entry]
mapEntriesLens :: forall key entry value.
(Ord key, Message entry) =>
Lens' entry key
-> Lens' entry value -> Lens' (Map key value) [entry]
mapEntriesLens Lens' entry key
kl Lens' entry value
vl = (Map key value -> [entry])
-> (Map key value -> [entry] -> Map key value)
-> Lens (Map key value) (Map key value) [entry] [entry]
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (Lens' entry key -> Lens' entry value -> Map key value -> [entry]
forall entry key value.
Message entry =>
Lens' entry key -> Lens' entry value -> Map key value -> [entry]
mapToEntries LensLike' f entry key
Lens' entry key
kl LensLike' f entry value
Lens' entry value
vl) (([entry] -> Map key value)
-> Map key value -> [entry] -> Map key value
forall a b. a -> b -> a
const (Lens' entry key -> Lens' entry value -> [entry] -> Map key value
forall key entry value.
Ord key =>
Lens' entry key -> Lens' entry value -> [entry] -> Map key value
entriesToMap LensLike' f entry key
Lens' entry key
kl LensLike' f entry value
Lens' entry value
vl))