WIP Bijective Read/Show instances for patterns

adds helper module Network.Socket.ReadShow for defining bijections
between types, to be used for simultaneous read-show equivalence
definitions

implements read/show instances for SocketOption, SockType, and Family
according to this paradigm

additionally removes a bug in Network.Socket.Options where
the OOBInline pattern name was unintentionally allcaps-ed in
one of the CPP ifdef branches

Author: archaephyrryx

Network/Socket/Options.hsc

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 
 #include "HsNet.h"
@@ -25,12 +26,15 @@ module Network.Socket.Options (
   , setSockOpt
   ) where
 
+import qualified Text.Read as P
+
 import Foreign.Marshal.Alloc (alloca)
 import Foreign.Marshal.Utils (with)
 
 import Network.Socket.Imports
 import Network.Socket.Internal
 import Network.Socket.Types
+import Network.Socket.ReadShow
 
 -----------------------------------------------------------------------------
 -- Socket Properties
@@ -39,10 +43,10 @@ import Network.Socket.Types
 --
 -- The existence of a constructor does not imply that the relevant option
 -- is supported on your system: see 'isSupportedSocketOption'
-data SocketOption = SockOpt {
-    sockOptLevel :: !CInt
-  , sockOptName  :: !CInt
-  } deriving (Eq, Show)
+data SocketOption = SockOpt
+    !CInt -- ^ Option Level
+    !CInt -- ^ Option Name
+  deriving (Eq)
 
 -- | Does the 'SocketOption' exist on this system?
 isSupportedSocketOption :: SocketOption -> Bool
@@ -141,7 +145,7 @@ pattern OOBInline :: SocketOption
 #ifdef SO_OOBINLINE
 pattern OOBInline      = SockOpt (#const SOL_SOCKET) (#const SO_OOBINLINE)
 #else
-pattern OOBINLINE      = SockOpt (-1) (-1)
+pattern OOBInline      = SockOpt (-1) (-1)
 #endif
 -- | SO_LINGER: timeout in seconds, 0 means disabling/disabled.
 pattern Linger :: SocketOption
@@ -376,6 +380,63 @@ getSockOpt s (SockOpt level opt) = do
                 c_getsockopt fd level opt ptr ptr_sz
         peek ptr
 
+
+socketOptionPairs :: [Pair SocketOption String]
+socketOptionPairs =
+    [ (Debug, "Debug")
+    , (ReuseAddr, "ReuseAddr")
+    , (SoDomain, "SoDomain")
+    , (Type, "Type")
+    , (SoProtocol, "SoProtocol")
+    , (SoError, "SoError")
+    , (DontRoute, "DontRoute")
+    , (Broadcast, "Broadcast")
+    , (SendBuffer, "SendBuffer")
+    , (RecvBuffer, "RecvBuffer")
+    , (KeepAlive, "KeepAlive")
+    , (OOBInline, "OOBInline")
+    , (Linger, "Linger")
+    , (ReusePort, "ReusePort")
+    , (RecvLowWater, "RecvLowWater")
+    , (SendLowWater, "SendLowWater")
+    , (RecvTimeOut, "RecvTimeOut")
+    , (SendTimeOut, "SendTimeOut")
+    , (UseLoopBack, "UseLoopBack")
+    , (MaxSegment, "MaxSegment")
+    , (NoDelay, "NoDelay")
+    , (UserTimeout, "UserTimeout")
+    , (Cork, "Cork")
+    , (TimeToLive, "TimeToLive")
+    , (RecvIPv4TTL, "RecvIPv4TTL")
+    , (RecvIPv4TOS, "RecvIPv4TOS")
+    , (RecvIPv4PktInfo, "RecvIPv4PktInfo")
+    , (IPv6Only, "IPv6Only")
+    , (RecvIPv6HopLimit, "RecvIPv6HopLimit")
+    , (RecvIPv6TClass, "RecvIPv6TClass")
+    , (RecvIPv6PktInfo, "RecvIPv6PktInfo")
+    ]
+
+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
+          _ -> error "socketOptionBijection: exception in WIP ReadShow code"
+        pairs = socketOptionPairs
+
+instance Show SocketOption where
+    show = forward socketOptionBijection
+
+instance Read SocketOption where
+    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward socketOptionBijection x
+
+
 foreign import CALLCONV unsafe "getsockopt"
   c_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt
 foreign import CALLCONV unsafe "setsockopt"

Network/Socket/ReadShow.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Network.Socket.ReadShow where
+
+-- type alias for individual correspondences of a (possibly partial) bijection
+type Pair a b = (a, b)
+
+-- | helper function for equality on first tuple element
+{-# INLINE eqFst #-}
+eqFst :: Eq a => a -> (a, b) -> Bool
+eqFst x = \(x',_) -> x' == x
+
+-- | helper function for equality on snd tuple element
+{-# INLINE eqSnd #-}
+eqSnd :: Eq b => b -> (a, b) -> Bool
+eqSnd y = \(_,y') -> y' == y
+
+-- | Return RHS element that is paired with provided LHS,
+--   or apply a default fallback function if the list is partial
+lookForward :: Eq a => (a -> b) -> [Pair a b] -> a -> b
+lookForward defFwd ps x
+  = case filter (eqFst x) ps of
+      (_,y):_ -> y
+      [] -> defFwd x
+
+-- | Return LHS element that is paired with provided RHS,
+--   or apply a default fallback function if the list is partial
+lookBackward :: Eq b => (b -> a) -> [Pair a b] -> b -> a
+lookBackward defBwd ps y
+  = case filter (eqSnd y) ps of
+      (x,_):_ -> x
+      [] -> defBwd y
+
+data Bijection a b
+   = Bijection
+     { defFwd :: a -> b
+     , defBwd :: b -> a
+     , pairs  :: [Pair a b]
+     }
+
+forward :: (Eq a) => Bijection a b -> a -> b
+forward Bijection{..} = lookForward defFwd pairs
+
+backward :: (Eq b) => Bijection a b -> b -> a
+backward Bijection{..} = lookBackward defBwd pairs