From b22cd03856810e97b312dcfa1f601a7e29c4b8ed Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <profunctor@pm.me>
Date: Wed, 12 Feb 2020 18:36:49 +0100
Subject: [PATCH] Remove code by resourting to a type family

By using 'OverlappedType' closed type family, we can remove two Storable
instances, which must be consistent with OVERLAPPEBLE / WSAOVERLAPPABLE
Storable instances (which was anyway enforced by using 'DerivingVia').
---
 .../src/System/Win32/Async/IOData.hsc         | 66 ++++++-------------
 1 file changed, 19 insertions(+), 47 deletions(-)

diff --git a/Win32-network/src/System/Win32/Async/IOData.hsc b/Win32-network/src/System/Win32/Async/IOData.hsc
index 8a904bd0f54..efbc1064b9f 100644
--- a/Win32-network/src/System/Win32/Async/IOData.hsc
+++ b/Win32-network/src/System/Win32/Async/IOData.hsc
@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE DerivingVia         #-}
 
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
@@ -72,20 +73,14 @@ data AsyncSing (asyncType :: AsyncType) where
     WsaAsyncSing :: AsyncSing WsaAsync
 
 
--- |  We use two overlapped structs: 'OVERLAPPED' or 'WSAOVERLAPPED'.  This is
--- a type safe wrapper for both.  The 'Storable' instances are derived
--- from storable instances of 'OVERLAPPED' or 'WSAOVERLAPPED' types.
+-- | This closed type family which maps 'AysncType' to overlapping type.
+-- Using only this type family, over using GADTs simplifies the types and
+-- number of storable instances as we can map directly @asyncType :: AsyncType@
+-- to the 'OVERLAPPED' or 'WSAOVERLAPPED' .
 --
-data Overlapped (a :: AsyncType) where
-    Overlapped :: OVERLAPPED
-               -> Overlapped Async
-
-    WsaOverlapped :: WSAOVERLAPPED
-                  -> Overlapped WsaAsync
-
-deriving via (Overlapped Async) instance Storable (Overlapped Async)
-
-deriving via (Overlapped WsaAsync) instance Storable (Overlapped WsaAsync)
+type family OverlappedType (asyncType :: AsyncType) :: * where
+  OverlappedType Async    = OVERLAPPED
+  OverlappedType WsaAsync = WSAOVERLAPPED
 
 
 --
@@ -111,7 +106,7 @@ deriving via (Overlapped WsaAsync) instance Storable (Overlapped WsaAsync)
 --  'WsaIOCPData' should be used.
 --
 data IOData (asyncType :: AsyncType) =
-    IOData { iodOverlapped :: Overlapped asyncType
+    IOData { iodOverlapped :: OverlappedType asyncType
              -- ^ overlapped structue passed through the iocp port
            , iodData       :: StablePtr (MVar (Either ErrCode Int))
              -- ^ associated stable pointer.
@@ -136,13 +131,13 @@ newIOData :: AsyncSing asyncType -> IO (IOData asyncType, MVar (Either ErrCode I
 newIOData AsyncSing    = do
     v <- newEmptyMVar
     p <- newStablePtr v
-    return ( IOData (Overlapped nullOVERLAPPED) p
+    return ( IOData nullOVERLAPPED p
            , v
            )
 newIOData WsaAsyncSing = do
     v <- newEmptyMVar
     p <- newStablePtr v
-    return ( IOData (WsaOverlapped nullWSAOVERLAPPED) p
+    return ( IOData nullWSAOVERLAPPED p
            , v
            )
 
@@ -154,35 +149,12 @@ newIOData WsaAsyncSing = do
 --
 -- >  ioData->iodOverlapped
 --
-iodOverlappedPtr' :: AsyncSing asyncType
+iodOverlappedPtr :: AsyncSing asyncType
                   -> Ptr (IOData asyncType)
-                  -> Ptr (Overlapped asyncType)
-iodOverlappedPtr' AsyncSing    = (#ptr IODATA,    iodOverlapped)
-iodOverlappedPtr' WsaAsyncSing = (#ptr WSAIODATA, iodOverlapped)
+                  -> Ptr (OverlappedType asyncType)
+iodOverlappedPtr AsyncSing    = (#ptr IODATA,    iodOverlapped)
+iodOverlappedPtr WsaAsyncSing = (#ptr WSAIODATA, iodOverlapped)
 
--- | This closed type family is only to make 'castOverlappedPtr' type safe.
--- We could use 'castPtr' but it would leek outside of this module.  This is
--- more elegant.
---
-type family OverlappedType (asyncType :: AsyncType) :: * where
-  OverlappedType Async    = OVERLAPPED
-  OverlappedType WsaAsync = WSAOVERLAPPED
-
--- | Cast 'Overlapped asyncType' to 'OverlappedType asyncType' which is either
--- 'OVERLAPPED' or 'WSAOVERLLAPPED'.  This is safe because the underlaying data
--- is layed out in the same way.
---
-castOverlappedPtr :: Ptr (Overlapped asyncType) -> Ptr (OverlappedType asyncType)
-castOverlappedPtr = castPtr
-
--- | Access the 'lpdOverlapped' member of the 'IODATA' or 'WSAIODATA' struct and
--- cast it the the correct overlapped type: either 'OVERLAPPED' or
--- 'WSAOVERLAPPED'.
---
-iodOverlappedPtr :: AsyncSing asyncType
-                 -> Ptr (IOData asyncType)
-                 -> Ptr (OverlappedType asyncType)
-iodOverlappedPtr asyncTag = castOverlappedPtr . iodOverlappedPtr' asyncTag
 
 -- | Access 'iodData' member of 'IODATA' or 'WSAIODATA' struct.
 --
@@ -200,14 +172,14 @@ instance Storable (IOData Async) where
     sizeOf    _ = (#const sizeof(IODATA))
     alignment _ = (#alignment IODATA)
 
-    poke buf IOData {iodOverlapped = Overlapped ovl, iodData} = do
+    poke buf IOData {iodOverlapped = ovl, iodData} = do
       (#poke IODATA, iodOverlapped) buf ovl
       (#poke IODATA, iodData)       buf iodData
 
     peek buf = do
       ovl     <- (#peek IODATA, iodOverlapped) buf
       iodData <- (#peek IODATA, iodData)       buf
-      return $ IOData { iodOverlapped = Overlapped ovl
+      return $ IOData { iodOverlapped = ovl
                       , iodData
                       }
 
@@ -215,14 +187,14 @@ instance Storable (IOData WsaAsync) where
     sizeOf    _ = (#const sizeof(WSAIODATA))
     alignment _ = (#alignment WSAIODATA)
 
-    poke buf IOData {iodOverlapped = WsaOverlapped ovl, iodData} = do
+    poke buf IOData {iodOverlapped = ovl, iodData} = do
       (#poke WSAIODATA, iodOverlapped) buf ovl
       (#poke WSAIODATA, iodData)       buf iodData
 
     peek buf = do
       ovl     <- (#peek WSAIODATA, iodOverlapped) buf
       iodData <- (#peek WSAIODATA, iodData)       buf
-      return $ IOData { iodOverlapped = WsaOverlapped ovl
+      return $ IOData { iodOverlapped = ovl
                       , iodData
                       }