[commit: packages/array] wip/rae: Fix #9220 by adding role annotations. (4baaf0b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/array

On branch  : wip/rae
Link       : http://git.haskell.org/packages/array.git/commitdiff/4baaf0b6d1e7498f529e41eaa3a065cfa84b078c

>---------------------------------------------------------------

commit 4baaf0b6d1e7498f529e41eaa3a065cfa84b078c
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Nov 7 17:30:58 2014 -0500

    Fix #9220 by adding role annotations.


>---------------------------------------------------------------

4baaf0b6d1e7498f529e41eaa3a065cfa84b078c
 Data/Array/Base.hs               | 12 ++++++++++++
 Data/Array/IO/Internals.hs       | 11 ++++++++++-
 Data/Array/Storable/Internals.hs |  9 ++++++++-
 tests/all.T                      |  2 +-
 4 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/Data/Array/Base.hs b/Data/Array/Base.hs
index 27e69c3..e00a97d 100644
--- a/Data/Array/Base.hs
+++ b/Data/Array/Base.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE BangPatterns, CPP, RankNTypes, MagicHash, UnboxedTuples, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, UnliftedFFITypes #-}
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE RoleAnnotations #-}
+#endif
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
@@ -402,6 +405,10 @@ instance IArray Arr.Array e where
 --
 data UArray i e = UArray !i !i !Int ByteArray#
                   deriving Typeable
+#if __GLASGOW_HASKELL__ >= 708
+-- There are class-based invariants on both parameters. See also #9220.
+type role UArray nominal nominal
+#endif
 
 {-# INLINE unsafeArrayUArray #-}
 unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
@@ -985,6 +992,11 @@ instance MArray (STArray s) e (Lazy.ST s) where
 -- 'STArray' provides.
 data STUArray s i e = STUArray !i !i !Int (MutableByteArray# s)
                       deriving Typeable
+#if __GLASGOW_HASKELL__ >= 708
+-- The "ST" parameter must be nominal for the safety of the ST trick.
+-- The other parameters have class constraints. See also #9220.
+type role STUArray nominal nominal nominal
+#endif
 
 instance Eq (STUArray s i e) where
     STUArray _ _ _ arr1# == STUArray _ _ _ arr2# =
diff --git a/Data/Array/IO/Internals.hs b/Data/Array/IO/Internals.hs
index 6761e99..1a015d9 100644
--- a/Data/Array/IO/Internals.hs
+++ b/Data/Array/IO/Internals.hs
@@ -1,4 +1,9 @@
-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,
+             CPP #-}
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE RoleAnnotations #-}
+#endif
+
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
@@ -47,6 +52,10 @@ import GHC.IOArray (IOArray(..))
 --
 newtype IOUArray i e = IOUArray (STUArray RealWorld i e)
                        deriving Typeable
+#if __GLASGOW_HASKELL__ >= 708
+-- Both parameters have class-based invariants. See also #9220.
+type role IOUArray nominal nominal
+#endif
 
 instance Eq (IOUArray i e) where
     IOUArray s1 == IOUArray s2  =  s1 == s2
diff --git a/Data/Array/Storable/Internals.hs b/Data/Array/Storable/Internals.hs
index c844aae..2e44fc1 100644
--- a/Data/Array/Storable/Internals.hs
+++ b/Data/Array/Storable/Internals.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, CPP #-}
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE RoleAnnotations #-}
+#endif
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
@@ -28,6 +31,10 @@ import Foreign hiding (newArray)
 
 -- |The array type
 data StorableArray i e = StorableArray !i !i Int !(ForeignPtr e)
+#if __GLASGOW_HASKELL__ >= 708
+-- Both parameters have class-based invariants. See also #9220.
+type role StorableArray nominal nominal
+#endif
 
 instance Storable e => MArray StorableArray e IO where
     getBounds (StorableArray l u _ _) = return (l,u)
diff --git a/tests/all.T b/tests/all.T
index cd3ae47..c563441 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -3,4 +3,4 @@ test('T2120', normal, compile_and_run, [''])
 test('largeArray', normal, compile_and_run, [''])
 test('array001',    extra_clean(['array001.data']), compile_and_run, [''])
 
-test('T9220', expect_broken(9220), ghci_script, ['T9220.script'])
+test('T9220', normal, ghci_script, ['T9220.script'])