Prefer codegen over deriving Generic in test suite (awakesecurity#14)

* Misc cleanup/refactor pass on test suite descriptions and structure (awakesecurity#13) * Rename module TestTypes => OldTestTypes * Rename test.proto and test_import.proto package names to GeneratedTestTypes and GeneratedImportedTestTypes respectively * +tests/Generated{,Imported}TestTypes.hs and related changes * Add (:: Int) annotation to enum bound to avoid default type warning in generated modules * (qcPropDecEncId test) Replace OldTestTypes types with GeneratedTestTypes types * Remove dependency on quickcheck-text * Add and support additional fields for `WithNesting` in test.proto We did this to match prior `NestedMsg` use in `OldTestTypes` as part of the effort of redirecting the test suite to operate on code generated from .protos rather than hand-rolled types. * Use GeneratedTestTypes for remainder of the current types under test (after making small tweaks for type parity) * Add pretty-show dep so it can be used in the repl * Fix bug in the `MessageField` instance for `PackedVec Word32` * Add helpers/instances for pprinting simplified, single-message DotProtos from corresponding Haskell types; comments * Minor module reorg * Remove warnings
litxio · May 30, 2017 · 3ee83b5 · 3ee83b5
1 parent dc1e4b1
commit 3ee83b5
Show file tree

Hide file tree

Showing 20 changed files with 1,683 additions and 502 deletions.
diff --git a/default.nix b/default.nix
@@ -1,5 +1,5 @@
 { mkDerivation, base, bytestring, cereal, containers, deepseq
-, filepath, haskell-src, mtl, parsec, parsers, pipes, pretty
+, filepath, haskell-src, mtl, parsec, parsers, pretty, pretty-show
 , proto3-wire, QuickCheck, safe, semigroups, stdenv, tasty
 , tasty-hunit, tasty-quickcheck, text, transformers, turtle, vector
 }:
@@ -9,12 +9,13 @@ mkDerivation {
   src = ./.;
   libraryHaskellDepends = [
     base bytestring cereal containers deepseq filepath haskell-src mtl
-    parsec parsers pipes pretty proto3-wire QuickCheck safe semigroups
-    text transformers vector
+    parsec parsers pretty pretty-show proto3-wire QuickCheck safe
+    semigroups text transformers vector
   ];
   testHaskellDepends = [
-    base bytestring cereal proto3-wire QuickCheck semigroups tasty
-    tasty-hunit tasty-quickcheck text transformers turtle
+    base bytestring cereal pretty-show proto3-wire QuickCheck
+    semigroups tasty tasty-hunit tasty-quickcheck text transformers
+    turtle vector
   ];
   description = "A low level library for writing out data in the Protocol Buffers wire format";
   license = stdenv.lib.licenses.asl20;

diff --git a/proto3-suite.cabal b/proto3-suite.cabal
@@ -31,6 +31,7 @@ library
                        parsec >= 3.1.9 && <3.2.0,
                        parsers >= 0.12 && <0.13,
                        pretty ==1.1.*,
+                       pretty-show >= 1.6.12 && < 1.7,
                        proto3-wire == 1.0.*,
                        QuickCheck >=2.8 && <3.0,
                        semigroups ==0.18.*,
@@ -46,7 +47,7 @@ library
 test-suite tests
   type:                exitcode-stdio-1.0
   main-is:             Main.hs
-  other-modules:       TestTypes TestCodeGen
+  other-modules:       OldTestTypes GeneratedTestTypes TestCodeGen
   hs-source-dirs:      tests
   build-depends:       base >=4.8 && <5.0,
                        tasty >= 0.11 && <0.12,
@@ -60,4 +61,6 @@ test-suite tests
                        cereal >= 0.5.1 && <0.6,
                        semigroups ==0.18.*,
                        transformers >=0.4 && <0.6,
-                       turtle >= 1.2.0
+                       turtle >= 1.2.0,
+                       pretty-show >= 1.6.12 && < 1.7,
+                       vector >=0.11 && < 0.13
diff --git a/src/Proto3/Suite/Class.hs b/src/Proto3/Suite/Class.hs
@@ -458,7 +458,7 @@ instance forall a. (Named a, Message a) => MessageField (NestedVec a) where
 instance MessageField (PackedVec Word32) where
   encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromIntegral
   decodeMessageField = decodePacked Decode.packedVarints
-  protoType _ = messageField (Prim UInt32) (Just DotProto.PackedField)
+  protoType _ = messageField (Repeated UInt32) (Just DotProto.PackedField)
 
 instance MessageField (PackedVec Word64) where
   encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromIntegral

diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs
@@ -559,7 +559,10 @@ dotProtoEnumD parentIdent enumIdent enumParts =
          -- TODO assert that there is more than one enumeration constructor
          minEnumVal = fst (head enumCons)
          maxEnumVal = fst (last enumCons)
-         boundsE = HsTuple [intE minEnumVal, intE maxEnumVal]
+         boundsE = HsTuple
+                     [ HsExpTypeSig l (intE minEnumVal) (HsQualType [] (HsTyCon (haskellName "Int")))
+                     , intE maxEnumVal
+                     ]
 
          toEnumD = toEnumDPatterns <> [ toEnumFailure ]
          fromEnumD =

diff --git a/test-files/make_reference_encodings.py b/test-files/make_reference_encodings.py
@@ -67,7 +67,7 @@ def main():
     trivNeg.trivialField = -1
     serialize_to_file(trivNeg, 'trivial_negative.bin')
 
-    withFixed = test_pb2.WithFixedTypes()
+    withFixed = test_pb2.WithFixed()
     withFixed.fixed1 = 16
     withFixed.fixed2 = -123
     withFixed.fixed3 = 4096

diff --git a/test-files/test.proto b/test-files/test.proto
@@ -1,5 +1,5 @@
 syntax = "proto3";
-package test;
+package GeneratedTestTypes;
 import "test-files/test_import.proto";
 
 message Trivial {
@@ -33,6 +33,8 @@ message WithNesting {
   message Nested {
     string nestedField1 = 1;
     int32 nestedField2 = 2;
+    repeated int32 nestedPacked = 3 [packed=true];
+    repeated int32 nestedUnpacked = 4 [packed=false];
   }
   Nested nestedMessage = 1;
 }
@@ -47,19 +49,24 @@ message WithNestingRepeated {
   repeated Nested nestedMessages = 1;
 }
 
-message WithNestingRepeatedInts {
-  message NestedInts {
+message NestedInts {
     int32 nestedInt1 = 1;
     int32 nestedInt2 = 2;
   }
+
+message WithNestingRepeatedInts {
   repeated NestedInts nestedInts = 1;
 }
 
+message WithNestingInts {
+  NestedInts nestedInts = 1;
+}
+
 message WithRepetition {
   repeated int32 repeatedField1 = 1;
 }
 
-message WithFixedTypes {
+message WithFixed {
   fixed32 fixed1 = 1;
   sfixed32 fixed2 = 2;
   fixed64 fixed3 = 3;
@@ -116,6 +123,10 @@ message WithQualifiedName {
 }
 
 message UsingImported {
-  test_import.WithNesting importedNesting = 100;
+  GeneratedImportedTestTypes.WithNesting importedNesting = 100;
   WithNesting localNesting = 200;
 }
+
+message Wrapped {
+  Wrapped wrapped = 1;
+}
diff --git a/test-files/test_import.proto b/test-files/test_import.proto
@@ -1,5 +1,5 @@
 syntax="proto3";
-package test_import;
+package GeneratedImportedTestTypes;
 
 message WithNesting {
   message Nested {

diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs
@@ -0,0 +1,75 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module ArbitraryGeneratedTestTypes where
+
+import qualified Data.ByteString    as BS
+import qualified Data.Text          as T
+import qualified Data.Vector        as V
+import           Test.QuickCheck    (Arbitrary, arbitrary, listOf)
+
+import           GeneratedTestTypes
+
+instance Arbitrary a => Arbitrary (V.Vector a) where
+  arbitrary = V.fromList <$> listOf arbitrary
+
+instance Arbitrary Trivial where
+  arbitrary = Trivial <$> arbitrary
+
+instance Arbitrary MultipleFields where
+  arbitrary =
+    MultipleFields
+    <$> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+    <*> fmap T.pack arbitrary
+    <*> arbitrary
+
+instance Arbitrary WithEnum where
+  arbitrary = WithEnum <$> arbitrary
+
+instance Arbitrary WithNesting_Nested where
+  arbitrary =
+    WithNesting_Nested
+    <$> fmap T.pack arbitrary
+    <*> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+
+instance Arbitrary WithNesting where
+  arbitrary = WithNesting <$> arbitrary
+
+instance Arbitrary WithRepetition where
+  arbitrary = WithRepetition <$> arbitrary
+
+instance Arbitrary WithFixed where
+  arbitrary = WithFixed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary WithBytes where
+  arbitrary = WithBytes <$> arbitrary <*> arbitrary
+
+instance Arbitrary BS.ByteString where
+  arbitrary = BS.pack <$> arbitrary
+
+instance Arbitrary AllPackedTypes where
+  arbitrary =
+    AllPackedTypes
+    <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary SignedInts where
+  arbitrary = SignedInts <$> arbitrary <*> arbitrary
+
+instance Arbitrary WithNestingRepeated where
+  arbitrary = WithNestingRepeated <$> arbitrary
+
+instance Arbitrary WithNestingRepeated_Nested where
+  arbitrary =
+    WithNestingRepeated_Nested
+    <$> fmap T.pack arbitrary
+    <*> arbitrary
+    <*> arbitrary
+    <*> arbitrary
+
+instance Arbitrary Wrapped where
+  arbitrary = Wrapped <$> arbitrary
diff --git a/tests/GeneratedImportedTestTypes.hs b/tests/GeneratedImportedTestTypes.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+-- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!
+module GeneratedImportedTestTypes where
+import qualified Prelude as Hs
+import qualified Proto3.Suite.DotProto as HsProtobuf
+import qualified Proto3.Suite.Types as HsProtobuf
+import qualified Proto3.Suite.Class as HsProtobuf
+import qualified Proto3.Wire as HsProtobuf
+import Control.Applicative ((<*>), (<|>))
+import qualified Data.Text as Hs (Text)
+import qualified Data.ByteString as Hs
+import qualified Data.String as Hs (fromString)
+import qualified Data.Vector as Hs (Vector)
+import qualified Data.Int as Hs (Int16, Int32, Int64)
+import qualified Data.Word as Hs (Word16, Word32, Word64)
+import GHC.Generics as Hs
+import GHC.Enum as Hs
+
+data WithNesting = WithNesting{withNestingNestedMessage1 ::
+                               Hs.Maybe WithNesting_Nested,
+                               withNestingNestedMessage2 :: Hs.Maybe WithNesting_Nested}
+                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)
+
+instance HsProtobuf.Named WithNesting where
+        nameOf _ = (Hs.fromString "WithNesting")
+
+instance HsProtobuf.Message WithNesting where
+        encodeMessage _
+          WithNesting{withNestingNestedMessage1 = withNestingNestedMessage1,
+                      withNestingNestedMessage2 = withNestingNestedMessage2}
+          = (Hs.mconcat
+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)
+                   (HsProtobuf.Nested withNestingNestedMessage1)),
+                (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)
+                   (HsProtobuf.Nested withNestingNestedMessage2))])
+        decodeMessage _
+          = (Hs.pure WithNesting) <*>
+              ((Hs.pure HsProtobuf.nested) <*>
+                 (HsProtobuf.at HsProtobuf.decodeMessageField
+                    (HsProtobuf.FieldNumber 1)))
+              <*>
+              ((Hs.pure HsProtobuf.nested) <*>
+                 (HsProtobuf.at HsProtobuf.decodeMessageField
+                    (HsProtobuf.FieldNumber 100)))
+        dotProto _
+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)
+                (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested")))
+                (HsProtobuf.Single "nestedMessage1")
+                []
+                Hs.Nothing),
+             (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 100)
+                (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested")))
+                (HsProtobuf.Single "nestedMessage2")
+                []
+                Hs.Nothing)]
+
+data WithNesting_Nested = WithNesting_Nested{withNesting_NestedNestedField1
+                                             :: Hs.Int32,
+                                             withNesting_NestedNestedField2 :: Hs.Int32}
+                        deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)
+
+instance HsProtobuf.Named WithNesting_Nested where
+        nameOf _ = (Hs.fromString "WithNesting_Nested")
+
+instance HsProtobuf.Message WithNesting_Nested where
+        encodeMessage _
+          WithNesting_Nested{withNesting_NestedNestedField1 =
+                               withNesting_NestedNestedField1,
+                             withNesting_NestedNestedField2 = withNesting_NestedNestedField2}
+          = (Hs.mconcat
+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)
+                   withNesting_NestedNestedField1),
+                (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)
+                   withNesting_NestedNestedField2)])
+        decodeMessage _
+          = (Hs.pure WithNesting_Nested) <*>
+              (HsProtobuf.at HsProtobuf.decodeMessageField
+                 (HsProtobuf.FieldNumber 1))
+              <*>
+              (HsProtobuf.at HsProtobuf.decodeMessageField
+                 (HsProtobuf.FieldNumber 2))
+        dotProto _
+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)
+                (HsProtobuf.Prim HsProtobuf.Int32)
+                (HsProtobuf.Single "nestedField1")
+                []
+                Hs.Nothing),
+             (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)
+                (HsProtobuf.Prim HsProtobuf.Int32)
+                (HsProtobuf.Single "nestedField2")
+                []
+                Hs.Nothing)]