WIP readshow for CmsgId and ghc-cpp guards

implements bijective read/show instances for CmsgId

adds missing ghc-dependent cpp guards around version-dependent
pragmas and inlined haddock annotations

adds commented-out pre-implementation of bijective read/show
boilerplate for MsgFlag type

Author: archaephyrryx

Network/Socket/Flag.hsc

@@ -10,6 +10,12 @@ import qualified Data.Semigroup as Sem
 
 import Network.Socket.Imports
 
+{-
+import Network.Socket.ReadShow
+
+import qualified Text.Read as P
+-}
+
 -- | Message flags. To combine flags, use '(<>)'.
 newtype MsgFlag = MsgFlag { fromMsgFlag :: CInt }
                 deriving (Show, Eq, Ord, Num, Bits)
@@ -78,3 +84,16 @@ pattern MSG_WAITALL = MsgFlag (#const MSG_WAITALL)
 #else
 pattern MSG_WAITALL = MsgFlag 0
 #endif
+
+{-
+msgFlagPairs :: [Pair MsgFlag String]
+msgFlagPairs =
+    [ (MSG_OOB, "MSG_OOB")
+    , (MSG_DONTROUTE, "MSG_DONTROUTE")
+    , (MSG_PEEK, "MSG_PEEK")
+    , (MSG_EOR, "MSG_EOR")
+    , (MSG_TRUNC, "MSG_TRUNC")
+    , (MSG_CTRUNC, "MSG_CTRUNC")
+    , (MSG_WAITALL, "MSG_WAITALL")
+    ]
+-}

Network/Socket/Options.hsc

@@ -44,8 +44,13 @@ import Network.Socket.ReadShow
 -- The existence of a constructor does not imply that the relevant option
 -- is supported on your system: see 'isSupportedSocketOption'
 data SocketOption = SockOpt
+#if __GLASGOW_HASKELL__ >= 806
     !CInt -- ^ Option Level
     !CInt -- ^ Option Name
+#else
+    !CInt -- Option Level
+    !CInt -- Option Name
+#endif
   deriving (Eq)
 
 -- | Does the 'SocketOption' exist on this system?
@@ -420,10 +425,6 @@ socketOptionBijection :: Bijection SocketOption String
 socketOptionBijection = Bijection{..}
     where
         cso = "CustomSockOpt"
-        _parse :: String -> (CInt, CInt)
-        _parse xy =
-            let (xs, ('_':ys)) = break (=='_') xy
-             in (read xs, read ys)
         defFwd = \(CustomSockOpt (n,m)) -> cso++show n++"_"++show m
         defBwd s = case splitAt (length cso) s of
           ("CustomSockOpt", nm) -> CustomSockOpt $ _parse nm

Network/Socket/Posix/Cmsg.hsc

@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -19,6 +20,9 @@ import System.Posix.Types (Fd(..))
 
 import Network.Socket.Imports
 import Network.Socket.Types
+import Network.Socket.ReadShow
+
+import qualified Text.Read as P
 
 -- | Control message (ancillary data) including a pair of level and type.
 data Cmsg = Cmsg {
@@ -32,7 +36,7 @@ data Cmsg = Cmsg {
 data CmsgId = CmsgId {
     cmsgLevel :: !CInt
   , cmsgType  :: !CInt
-  } deriving (Eq, Show)
+  } deriving (Eq)
 
 -- | The identifier for 'IPv4TTL'.
 pattern CmsgIdIPv4TTL :: CmsgId
@@ -220,3 +224,31 @@ instance Storable IPv6PktInfo where
 
 instance ControlMessage Fd where
     controlMessageId = CmsgIdFd
+
+cmsgIdPairs :: [Pair CmsgId String]
+cmsgIdPairs =
+    [ (CmsgIdIPv4TTL, "CmsgIdIPv4TTL")
+    , (CmsgIdIPv6HopLimit, "CmsgIdIPv6HopLimit")
+    , (CmsgIdIPv4TOS, "CmsgIdIPv4TOS")
+    , (CmsgIdIPv6TClass, "CmsgIdIPv6TClass")
+    , (CmsgIdIPv4PktInfo, "CmsgIdIPv4PktInfo")
+    , (CmsgIdIPv6PktInfo, "CmsgIdIPv6PktInfo")
+    , (CmsgIdFd, "CmsgIdFd")
+    ]
+
+cmsgIdBijection :: Bijection CmsgId String
+cmsgIdBijection = Bijection{..}
+    where
+        defname = "CmsgId"
+        defFwd = \(CmsgId l t) -> defname++show l++"_" ++show t
+        defBwd s =
+            case splitAt (length defname) s of
+                ("CmsgId", nm) -> uncurry CmsgId $ _parse nm
+                _ -> error "cmsgIdBijection: exception in WIP ReadShow code"
+        pairs = cmsgIdPairs
+
+instance Show CmsgId where
+    show = forward cmsgIdBijection
+
+instance Read CmsgId where
+    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward cmsgIdBijection x

Network/Socket/ReadShow.hs

@@ -38,8 +38,19 @@ data Bijection a b
      , pairs  :: [Pair a b]
      }
 
+-- | apply a bijection over an LHS-value
 forward :: (Eq a) => Bijection a b -> a -> b
 forward Bijection{..} = lookForward defFwd pairs
 
+-- | apply a bijection over an RHS-value
 backward :: (Eq b) => Bijection a b -> b -> a
 backward Bijection{..} = lookBackward defBwd pairs
+
+-- | parse an underscore-separated pair into a tuple
+--   should not be used if either type might have
+--   literal underscores in the Read pre-image
+_parse :: (Read a, Read b) => String -> (a, b)
+_parse xy =
+  let (xs, '_':ys) = break (=='_') xy
+   in (read xs, read ys)
+