Introduce pattern-synonym bias to rountrip tests

Modifies Network.SocketSpec test cases to specifically bias towards pattern synonym values when testing for
roundtrip read-show equality for types with bijectively defined read/show instances

tests/Network/SocketSpec.hs

@@ -7,6 +7,7 @@ import Control.Concurrent (threadDelay, forkIO)
 import Control.Concurrent.MVar (readMVar)
 import Control.Monad
 import Data.Maybe (fromJust)
+import Data.List (nub)
 import Network.Socket
 import Network.Socket.ByteString
 import Network.Test.Common
@@ -386,17 +387,88 @@ spec = do
             show msgid `shouldBe` "CmsgId (-300) (-300)"
 
     describe "bijective read-show roundtrip equality" $ do
-        it "works for Family" $ property $
-            \x -> (read . show $ GeneralFamily x) == GeneralFamily (x :: CInt)
-
-        it "works for SocketType" $ property $
-            \x -> (read . show $ GeneralSocketType x) == GeneralSocketType (x :: CInt)
-
-        it "works for SocketOption" $ property $
-            \(x,y) -> (read . show $ SockOpt x y) == SockOpt (x :: CInt) (y :: CInt)
-
-        it "works for CmsgId" $ property $
-            \(x,y) -> (read . show $ CmsgId x y) == CmsgId (x :: CInt) (y :: CInt)
-
-
-
+        it "holds for Family" $ forAll familyGen $
+            \x -> (read . show $ x) == (x :: Family)
+
+        it "holds for SocketType" $ forAll socktypeGen $
+            \x -> (read . show $ x) == (x :: SocketType)
+
+        it "holds for SocketOption" $ forAll sockoptGen $
+            \x -> (read . show $ x) == (x :: SocketOption)
+
+        it "holds for CmsgId" $ forAll cmsgidGen $
+            \x -> (read . show $ x) == (x :: CmsgId)
+
+
+-- Type-specific generators with strong bias towards pattern synonyms
+
+-- Generator combinator that biases elements of a given list and otherwise
+-- applies a function to a given generator
+biasedGen :: (Gen a -> Gen b) -> [b] -> Gen a -> Gen b
+biasedGen f xs g = do
+    useBias <- (arbitrary :: Gen Bool)
+    if useBias
+       then elements xs
+       else f g
+
+familyGen :: Gen Family
+familyGen = biasedGen (fmap GeneralFamily) familyPatterns arbitrary
+
+socktypeGen :: Gen SocketType
+socktypeGen = biasedGen (fmap GeneralSocketType) socktypePatterns arbitrary
+
+sockoptGen :: Gen SocketOption
+sockoptGen = biasedGen (\g -> SockOpt <$> g <*> g) sockoptPatterns arbitrary
+
+cmsgidGen :: Gen CmsgId
+cmsgidGen = biasedGen (\g -> CmsgId <$> g <*> g) cmsgidPatterns arbitrary
+
+-- pruned lists of pattern synonym values for each type to generate values from
+
+familyPatterns :: [Family]
+familyPatterns = nub
+    [UnsupportedFamily
+    ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS
+    ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet
+    ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS
+    ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET
+    ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE
+    ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP
+    ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT
+    ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC
+    ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET
+    ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN]
+
+socktypePatterns :: [SocketType]
+socktypePatterns = nub
+    [ UnsupportedSocketType
+    , NoSocketType
+    , Stream
+    , Datagram
+    , Raw
+    , RDM
+    , SeqPacket
+    ]
+
+sockoptPatterns :: [SocketOption]
+sockoptPatterns = nub
+    [UnsupportedSocketOption
+    ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute
+    ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive
+    ,MaxSegment,NoDelay,Cork,Linger,ReusePort
+    ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut
+    ,UseLoopBack,UserTimeout,IPv6Only
+    ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo
+    ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo]
+
+cmsgidPatterns :: [CmsgId]
+cmsgidPatterns = nub
+    [ UnsupportedCmsgId
+    , CmsgIdIPv4TTL
+    , CmsgIdIPv6HopLimit
+    , CmsgIdIPv4TOS
+    , CmsgIdIPv6TClass
+    , CmsgIdIPv4PktInfo
+    , CmsgIdIPv6PktInfo
+    , CmsgIdFd
+    ]