Unified ReadShow usage patterns

Unifies several common usage patterns of Network.Socket.ReadShow
for types with bijective read/show definitions, consolidating
reused boilerplate code to in-module functions

Author: archaephyrryx

Network/Socket/Options.hsc

@@ -430,17 +430,16 @@ socketOptionBijection :: Bijection SocketOption String
 socketOptionBijection = Bijection{..}
     where
         cso = "CustomSockOpt"
-        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"
+        unCSO = \(CustomSockOpt nm) -> nm
+        defFwd = defShow cso unCSO _show
+        defBwd = defRead cso CustomSockOpt _parse
         pairs = socketOptionPairs
 
 instance Show SocketOption where
     show = forward socketOptionBijection
 
 instance Read SocketOption where
-    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward socketOptionBijection x
+    readPrec = tokenize $ backward socketOptionBijection
 
 
 foreign import CALLCONV unsafe "getsockopt"

Network/Socket/Posix/Cmsg.hsc

@@ -245,15 +245,13 @@ 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"
+        unId = \(CmsgId l t) -> (l,t)
+        defFwd = defShow defname unId _show
+        defBwd = defRead defname (uncurry CmsgId) _parse
         pairs = cmsgIdPairs
 
 instance Show CmsgId where
     show = forward cmsgIdBijection
 
 instance Read CmsgId where
-    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward cmsgIdBijection x
+    readPrec = tokenize $ backward cmsgIdBijection

Network/Socket/ReadShow.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternGuards #-}
+
 
 module Network.Socket.ReadShow where
 
+import qualified Text.Read as P
+
 -- type alias for individual correspondences of a (possibly partial) bijection
 type Pair a b = (a, b)
 
@@ -53,4 +57,24 @@ _parse :: (Read a, Read b) => String -> (a, b)
 _parse xy =
   let (xs, '_':ys) = break (=='_') xy
    in (read xs, read ys)
+{-# INLINE _parse #-}
+
+-- | inverse function to _parse
+--   show a tuple as underscore-separated strings
+_show :: (Show a, Show b) => (a, b) -> String
+_show (x, y) = show x ++ "_" ++ show y
+
+{-# INLINE defShow #-}
+defShow :: Eq a => String -> (a -> b) -> (b -> String) -> (a -> String)
+defShow name get sho = \x -> name ++ (sho . get $ x)
+
+{-# INLINE defRead #-}
+defRead :: Read a => String -> (b -> a) -> (String -> b) -> (String -> a)
+defRead name set red = \s ->
+  case splitAt (length name) s of
+    (x, sn) | x == name -> set $ red sn
+    _ -> error $ "defRead: unable to parse " ++ show s
 
+{-# INLINE tokenize #-}
+tokenize :: (String -> a) -> P.ReadPrec a
+tokenize f = P.lexP >>= \(P.Ident x) -> return $ f x

Network/Socket/Types.hsc

@@ -1331,18 +1331,15 @@ socktypeBijection :: Bijection SocketType String
 socktypeBijection = Bijection{..}
     where
       gst = "GeneralSocketType"
-      defFwd = \(GeneralSocketType n) -> gst++show n
-      defBwd = \s ->
-          case splitAt (length gst) s of
-            ("GeneralSocketType", sn) -> GeneralSocketType $ (read sn :: CInt)
-            _ -> error "socktypeBijection: exception in WIP ReadShow code"
+      defFwd = defShow gst packSocketType show
+      defBwd = defRead gst unpackSocketType read
       pairs = socktypePairs
 
 instance Show SocketType where
     show = forward socktypeBijection
 
 instance Read SocketType where
-    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward socktypeBijection x
+    readPrec = tokenize $ backward socktypeBijection
 
 familyPairs :: [Pair Family String]
 familyPairs =
@@ -1419,18 +1416,15 @@ familyBijection :: Bijection Family String
 familyBijection = Bijection{..}
     where
       gf = "GeneralFamily"
-      defFwd = \(GeneralFamily n) -> gf++show n
-      defBwd = \s ->
-          case splitAt (length gf) s of
-            ("GeneralFamily", sn) -> GeneralFamily $ (read sn :: CInt)
-            _ -> error "familyBijection: exception in WIP ReadShow code"
+      defFwd = defShow gf packFamily show
+      defBwd = defRead gf unpackFamily read
       pairs = familyPairs
 
 instance Show Family where
     show = forward familyBijection
 
 instance Read Family where
-    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward familyBijection x
+    readPrec = tokenize $ backward familyBijection
 
 -- Print "n" instead of "PortNum n".
 instance Show PortNumber where

Network/Socket/Win32/Cmsg.hsc

@@ -202,15 +202,13 @@ 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"
+        unId = \(CmsgId l t) -> (l,t)
+        defFwd = defShow defname unId _show
+        defBwd = defRead defname (uncurry CmsgId) _parse
         pairs = cmsgIdPairs
 
 instance Show CmsgId where
     show = forward cmsgIdBijection
 
 instance Read CmsgId where
-    readPrec = P.lexP >>= \(P.Ident x) -> return $ backward cmsgIdBijection x
+    readPrec = tokenize $ backward cmsgIdBijection