Implement fmap/coerce rules

Implement fmap/coerce rules for Map, Sequence, and Tree. One concern:
unfortunately, implementing the RULES forces the LANGUAGE to be turned
from Safe to Trustworthy.  This is rather sad. An alternative would be
to do this in another module, but orphan rules are not so lovely either.

Author: treeowl

Data/Map/Base.hs

@@ -9,6 +9,12 @@
 {-# LANGUAGE RoleAnnotations #-}
 {-# 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.Map.Base
@@ -288,6 +294,9 @@ import qualified GHC.Exts as GHCExts
 import Text.Read
 import Data.Data
 #endif
+#if MIN_VERSION_base(4,8,0)
+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.
@@ -299,13 +308,6 @@ import Data.Data
 #define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined
 #define STRICT_2_OF_4(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
-
 
 {--------------------------------------------------------------------
   Operators
@@ -1660,6 +1662,14 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0
 map :: (a -> b) -> Map k a -> Map k b
 map _ Tip = Tip
 map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r)
+#if MIN_VERSION_base(4,8,0)
+-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
+-- well enough with RULES to do what we want.
+{-# NOINLINE [1] map #-}
+{-# RULES
+"map/coerce" map coerce = coerce
+ #-}
+#endif
 
 -- | /O(n)/. Map a function over all values in the map.
 --

Data/Map/Strict.hs

@@ -1,6 +1,12 @@
 {-# LANGUAGE CPP #-}
 #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
+#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
 -----------------------------------------------------------------------------
 -- |
@@ -273,6 +279,9 @@ import Data.Utils.StrictFold
 import Data.Utils.StrictPair
 
 import Data.Bits (shiftL, shiftR)
+#if MIN_VERSION_base(4,8,0)
+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. Similarly
@@ -926,6 +935,14 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0
 map :: (a -> b) -> Map k a -> Map k b
 map _ Tip = Tip
 map f (Bin sx kx x l r) = let x' = f x in x' `seq` Bin sx kx x' (map f l) (map f r)
+#if MIN_VERSION_base(4,8,0)
+-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
+-- well enough with RULES to do what we want.
+{-# NOINLINE [1] map #-}
+{-# RULES
+"mapSeq/coerce" map coerce = coerce
+ #-}
+#endif
 
 -- | /O(n)/. Map a function over all values in the map.
 --

Data/Sequence.hs

@@ -5,6 +5,12 @@
 #if __GLASGOW_HASKELL__ >= 703
 {-# LANGUAGE Trustworthy #-}
 #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.Sequence
@@ -159,12 +165,8 @@ import Text.Read (Lexeme(Ident), lexP, parens, prec,
     readPrec, readListPrec, readListPrecDefault)
 import Data.Data
 #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
+#if MIN_VERSION_base(4,8,0)
+import Data.Coerce
 #endif
 
 
@@ -182,11 +184,22 @@ class Sized a where
 newtype Seq a = Seq (FingerTree (Elem a))
 
 instance Functor Seq where
-    fmap f (Seq xs) = Seq (fmap (fmap f) xs)
+    fmap = fmapSeq
 #ifdef __GLASGOW_HASKELL__
     x <$ s = replicate (length s) x
 #endif
 
+fmapSeq :: (a -> b) -> Seq a -> Seq b
+fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
+#if MIN_VERSION_base(4,8,0)
+-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
+-- well enough with RULES to do what we want.
+{-# NOINLINE [1] fmapSeq #-}
+{-# RULES
+"fmapSeq/coerce" fmapSeq coerce = coerce
+ #-}
+#endif
+
 instance Foldable Seq where
     foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
     foldl f z (Seq xs) = foldl (foldl f) z xs

Data/Tree.hs

@@ -3,8 +3,15 @@
 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
 #endif
 #if __GLASGOW_HASKELL__ >= 703
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 #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.Tree
@@ -45,11 +52,8 @@ import Control.DeepSeq (NFData(rnf))
 import Data.Data (Data)
 #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
+#if MIN_VERSION_base(4,8,0)
+import Data.Coerce
 #endif
 
 
@@ -69,7 +73,18 @@ type Forest a = [Tree a]
 INSTANCE_TYPEABLE1(Tree,treeTc,"Tree")
 
 instance Functor Tree where
-    fmap f (Node x ts) = Node (f x) (map (fmap f) ts)
+    fmap = fmapTree
+
+fmapTree :: (a -> b) -> Tree a -> Tree b
+fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)
+#if MIN_VERSION_base(4,8,0)
+-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
+-- well enough with RULES to do what we want.
+{-# NOINLINE [1] fmapTree #-}
+{-# RULES
+"fmapTree/coerce" fmapTree coerce = coerce
+ #-}
+#endif
 
 instance Applicative Tree where
     pure x = Node x []

tests-ghc/all.T

@@ -5,3 +5,6 @@ test('datamap001', normal, compile_and_run, ['-package containers'])
 test('datamap002', normal, compile_and_run, ['-package containers'])
 test('dataintset001', normal, compile_and_run, ['-package containers'])
 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'])

tests-ghc/mapcoercemap.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts hiding (fromList)
+import Unsafe.Coerce
+import Data.Map
+
+newtype Age = Age Int
+
+fooAge :: Map Int Int -> Map Int Age
+fooAge = fmap Age
+fooCoerce :: Map Int Int -> Map Int Age
+fooCoerce = fmap coerce
+fooUnsafeCoerce :: Map Int Int -> Map Int 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/mapcoercemap.stdout

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

tests-ghc/mapcoerceseq.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts hiding (fromList)
+import Unsafe.Coerce
+import Data.Sequence
+
+newtype Age = Age Int
+
+fooAge :: Seq Int -> Seq Age
+fooAge = fmap Age
+fooCoerce :: Seq Int -> Seq Age
+fooCoerce = fmap coerce
+fooUnsafeCoerce :: Seq Int -> Seq 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,2,3]
+    same (fooAge l) l
+    same (fooCoerce l) l
+    same (fooUnsafeCoerce l) l

tests-ghc/mapcoerceseq.stdout

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

tests-ghc/mapcoercesmap.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts hiding (fromList)
+import Unsafe.Coerce
+import Data.Map.Strict
+
+newtype Age = Age Int
+
+fooAge :: Map Int Int -> Map Int Age
+fooAge = fmap Age
+fooCoerce :: Map Int Int -> Map Int Age
+fooCoerce = fmap coerce
+fooUnsafeCoerce :: Map Int Int -> Map Int 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