Merge pull request #71 from treeowl/fmapcoerceintmap

Implement map/coerce for IntMap

Author: foxik

Data/IntMap/Base.hs

@@ -9,6 +9,13 @@
 #if __GLASGOW_HASKELL__ >= 708
 {-# LANGUAGE TypeFamilies #-}
 #endif
+-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
+-- Nevertheless, as a convenience, we also allow compiling without cabal by
+-- defining trivial MIN_VERSION_base if needed.
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(major1,major2,minor) 0
+#endif
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.IntMap.Base
@@ -240,20 +247,16 @@ import qualified GHC.Exts as GHCExts
 #endif
 import Text.Read
 #endif
+#if __GLASGOW_HASKELL__ >= 709
+import Data.Coerce
+#endif
 
 -- Use macros to define strictness of functions.
 -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
 -- We do not use BangPatterns, because they are not in any standard and we
 -- want the compilers to be compiled by as many compilers as possible.
 #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
 
--- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
--- Nevertheless, as a convenience, we also allow compiling without cabal by
--- defining trivial MIN_VERSION_base if needed.
-#ifndef MIN_VERSION_base
-#define MIN_VERSION_base(major1,major2,minor) 0
-#endif
-
 
 -- A "Nat" is a natural machine word (an unsigned Int)
 type Nat = Word
@@ -1307,6 +1310,12 @@ map f t
 "map/map" forall f g xs . map f (map g xs) = map (f . g) xs
  #-}
 #endif
+#if __GLASGOW_HASKELL__ >= 709
+-- Safe coercions were introduced in 7.8, but did not play well with RULES yet.
+{-# RULES
+"map/coerce" map coerce = coerce
+ #-}
+#endif
 
 -- | /O(n)/. Map a function over all values in the map.
 --

Data/IntMap/Strict.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE CPP #-}
-#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 709
-{-# LANGUAGE Safe #-}
-#elif !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
 {-# LANGUAGE Trustworthy #-}
 #endif
 -----------------------------------------------------------------------------
@@ -262,6 +260,9 @@ import qualified Data.IntSet.Base as IntSet
 import Data.Utils.BitUtil
 import Data.Utils.StrictFold
 import Data.Utils.StrictPair
+#if __GLASGOW_HASKELL__ >= 709
+import Data.Coerce
+#endif
 
 -- $strictness
 --
@@ -724,6 +725,11 @@ map f t
 "map/map" forall f g xs . map f (map g xs) = map (f . g) xs
  #-}
 #endif
+#if __GLASGOW_HASKELL__ >= 709
+{-# RULES
+"map/coerce" map coerce = coerce
+ #-}
+#endif
 
 -- | /O(n)/. Map a function over all values in the map.
 --

tests-ghc/all.T

@@ -8,3 +8,5 @@ test('sequence001', normal, compile_and_run, ['-package containers'])
 test('mapcoerceseq', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])
 test('mapcoercemap', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])
 test('mapcoercesmap', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])
+test('mapcoerceintmap', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])
+test('mapcoerceintmapstrict', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])

tests-ghc/mapcoerceintmap.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts hiding (fromList)
+import Unsafe.Coerce
+import Data.IntMap.Lazy
+
+newtype Age = Age Int
+
+fooAge :: IntMap Int -> IntMap Age
+fooAge = fmap Age
+fooCoerce :: IntMap Int -> IntMap Age
+fooCoerce = fmap coerce
+fooUnsafeCoerce :: IntMap Int -> IntMap Age
+fooUnsafeCoerce = fmap unsafeCoerce
+
+same :: a -> b -> IO ()
+same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
+    1# -> putStrLn "yes"
+    _  -> putStrLn "no"
+
+main = do
+    let l = fromList [(1,1),(2,2),(3,3)]
+    same (fooAge l) l
+    same (fooCoerce l) l
+    same (fooUnsafeCoerce l) l

tests-ghc/mapcoerceintmap.stdout

@@ -0,0 +1,3 @@
+yes
+yes
+yes

tests-ghc/mapcoerceintmapstrict.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts hiding (fromList)
+import Unsafe.Coerce
+import Data.IntMap.Strict as IM
+
+newtype Age = Age Int
+
+fooAge :: IntMap Int -> IntMap Age
+fooAge = IM.map Age
+fooCoerce :: IntMap Int -> IntMap Age
+fooCoerce = IM.map coerce
+fooUnsafeCoerce :: IntMap Int -> IntMap Age
+fooUnsafeCoerce = IM.map unsafeCoerce
+
+same :: a -> b -> IO ()
+same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
+    1# -> putStrLn "yes"
+    _  -> putStrLn "no"
+
+main = do
+    let l = fromList [(1,1),(2,2),(3,3)]
+    same (fooAge l) l
+    same (fooCoerce l) l
+    same (fooUnsafeCoerce l) l

tests-ghc/mapcoerceintmapstrict.hs.stdout

@@ -0,0 +1,3 @@
+yes
+yes
+yes