Add `Storable` instances for `Complex` and `Ratio`

The actual type-signatures of the new instances are:

  instance Storable a => Storable (Complex a)

  instance (Storable a, Integral a) => Storable (Ratio a)

See also

  https://groups.google.com/d/msg/haskell-core-libraries/mjBSo2CQ3LU/0gwg0QvviOIJ

Addresses #9826

Reviewed By: ekmett

Differential Revision: https://phabricator.haskell.org/D519

6 files changed, 58 insertions, 0 deletions

diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs
index 2baa60bd36..1c06d46cd9 100644
--- a/libraries/base/Data/Complex.hs
+++ b/libraries/base/Data/Complex.hs
@@ -36,6 +36,8 @@ module Data.Complex
 
 import Data.Typeable
 import Data.Data (Data)
+import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf,
+                alignment)
 
 infix  6  :+
 
@@ -171,3 +173,16 @@ instance  (RealFloat a) => Floating (Complex a) where
     asinh z        =  log (z + sqrt (1+z*z))
     acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
     atanh z        =  0.5 * log ((1.0+z) / (1.0-z))
+
+instance Storable a => Storable (Complex a) where
+    sizeOf a       = 2 * sizeOf (realPart a)
+    alignment a    = alignment (realPart a)
+    peek p           = do
+                        q <- return $ castPtr p
+                        r <- peek q
+                        i <- peekElemOff q 1
+                        return (r :+ i)
+    poke p (r :+ i)  = do
+                        q <-return $  (castPtr p)
+                        poke q r
+                        pokeElemOff q 1 i
diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs
index 35b1b494ac..52f3edab9a 100644
--- a/libraries/base/Foreign/Storable.hs
+++ b/libraries/base/Foreign/Storable.hs
@@ -208,6 +208,19 @@ STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
 STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
          readInt64OffPtr,writeInt64OffPtr)
 
+instance (Storable a, Integral a) => Storable (Ratio a) where
+    sizeOf _    = 2 * sizeOf (undefined :: a)
+    alignment _ = alignment (undefined :: a )
+    peek p           = do
+                        q <- return $ castPtr p
+                        r <- peek q
+                        i <- peekElemOff q 1
+                        return (r % i)
+    poke p (r :% i)  = do
+                        q <-return $  (castPtr p)
+                        poke q r
+                        pokeElemOff q 1 i
+
 -- XXX: here to avoid orphan instance in GHC.Fingerprint
 instance Storable Fingerprint where
   sizeOf _ = 16
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 881532f2e0..c7de12e55a 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -113,6 +113,10 @@
     representing non-negative arbitrary-precision integers.  The `GHC.Natural`
     module exposes additional GHC-specific primitives. (#9818)
 
+  * Add `(Storable a, Integeral a) => Storable (Ratio a)` instance (#9826)
+
+  * Add `Storable a => Storable (Complex a)` instance (#9826)
+
 ## 4.7.0.1  *Jul 2014*
 
   * Bundled with GHC 7.8.3
diff --git a/libraries/base/tests/T9826.hs b/libraries/base/tests/T9826.hs
new file mode 100644
index 0000000000..b35ada4834
--- /dev/null
+++ b/libraries/base/tests/T9826.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+--import qualified Data.Vector.Storable as V
+import Foreign
+import Data.Ratio
+import Data.Complex
+
+complexZI :: Complex Int
+complexZI = 1 :+ 1
+
+ratio23 :: Ratio Int
+ratio23 =  1 % 1
+
+putter :: Storable a => a -> Ptr a -> IO a
+putter v !ptr = do poke ptr v ; peek ptr
+
+main =
+  do
+      !vComplex <- alloca (putter complexZI)
+      !vRatio <- alloca (putter ratio23)
+      if vComplex  == complexZI &&  vRatio  == ratio23
+        then putStrLn "success"
+        else putStrLn "uh oh, something is wrong with storable"
diff --git a/libraries/base/tests/T9826.stdout b/libraries/base/tests/T9826.stdout
new file mode 100644
index 0000000000..2e9ba477f8
--- /dev/null
+++ b/libraries/base/tests/T9826.stdout
@@ -0,0 +1 @@
+success
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index fa8ecd3d47..d4686e5dee 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -178,3 +178,4 @@ test('T9532', normal, compile_and_run, [''])
 test('T9586', normal, compile, [''])
 test('T9681', normal, compile_fail, [''])
 test('T8089', normal, compile_and_run, [''])
+test('T9826',normal, compile_and_run,[''])