Skip to content

Commit e083f68

Browse files
foxikfoxik
committed
Merge pull request #66 from treeowl/seqfmapcoerce
Implement fmap/coerce rules
2 parents 94fa013 + ad24ce6 commit e083f68

File tree

11 files changed

+164
-22
lines changed

11 files changed

+164
-22
lines changed

‎Data/Map/Base.hs

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,12 @@
99
{-# LANGUAGE RoleAnnotations #-}
1010
{-# LANGUAGE TypeFamilies #-}
1111
#endif
12+
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
13+
-- Nevertheless, as a convenience, we also allow compiling without cabal by
14+
-- defining trivial MIN_VERSION_base if needed.
15+
#ifndef MIN_VERSION_base
16+
#define MIN_VERSION_base(major1,major2,minor) 0
17+
#endif
1218
-----------------------------------------------------------------------------
1319
-- |
1420
-- Module : Data.Map.Base
@@ -288,6 +294,9 @@ import qualified GHC.Exts as GHCExts
288294
import Text.Read
289295
import Data.Data
290296
#endif
297+
#if MIN_VERSION_base(4,8,0)
298+
import Data.Coerce
299+
#endif
291300

292301
-- Use macros to define strictness of functions.
293302
-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
@@ -299,13 +308,6 @@ import Data.Data
299308
#define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined
300309
#define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined
301310

302-
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
303-
-- Nevertheless, as a convenience, we also allow compiling without cabal by
304-
-- defining trivial MIN_VERSION_base if needed.
305-
#ifndef MIN_VERSION_base
306-
#define MIN_VERSION_base(major1,major2,minor) 0
307-
#endif
308-
309311

310312
{--------------------------------------------------------------------
311313
Operators
@@ -1660,6 +1662,14 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0
16601662
map :: (a -> b) -> Map k a -> Map k b
16611663
map _ Tip = Tip
16621664
map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r)
1665+
#if MIN_VERSION_base(4,8,0)
1666+
-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
1667+
-- well enough with RULES to do what we want.
1668+
{-# NOINLINE [1] map #-}
1669+
{-# RULES
1670+
"map/coerce" map coerce = coerce
1671+
#-}
1672+
#endif
16631673

16641674
-- | /O(n)/. Map a function over all values in the map.
16651675
--

‎Data/Map/Strict.hs

Lines changed: 18 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,12 @@
11
{-# LANGUAGE CPP #-}
22
#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
3-
{-# LANGUAGE Safe #-}
3+
{-# LANGUAGE Trustworthy #-}
4+
#endif
5+
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
6+
-- Nevertheless, as a convenience, we also allow compiling without cabal by
7+
-- defining trivial MIN_VERSION_base if needed.
8+
#ifndef MIN_VERSION_base
9+
#define MIN_VERSION_base(major1,major2,minor) 0
410
#endif
511
-----------------------------------------------------------------------------
612
-- |
@@ -273,6 +279,9 @@ import Data.Utils.StrictFold
273279
import Data.Utils.StrictPair
274280

275281
import Data.Bits (shiftL, shiftR)
282+
#if MIN_VERSION_base(4,8,0)
283+
import Data.Coerce
284+
#endif
276285

277286
-- Use macros to define strictness of functions. STRICT_x_OF_y
278287
-- denotes an y-ary function strict in the x-th parameter. Similarly
@@ -926,6 +935,14 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0
926935
map :: (a -> b) -> Map k a -> Map k b
927936
map _ Tip = Tip
928937
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)
938+
#if MIN_VERSION_base(4,8,0)
939+
-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
940+
-- well enough with RULES to do what we want.
941+
{-# NOINLINE [1] map #-}
942+
{-# RULES
943+
"mapSeq/coerce" map coerce = coerce
944+
#-}
945+
#endif
929946

930947
-- | /O(n)/. Map a function over all values in the map.
931948
--

‎Data/Sequence.hs

Lines changed: 20 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,12 @@
55
#if __GLASGOW_HASKELL__ >= 703
66
{-# LANGUAGE Trustworthy #-}
77
#endif
8+
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
9+
-- Nevertheless, as a convenience, we also allow compiling without cabal by
10+
-- defining trivial MIN_VERSION_base if needed.
11+
#ifndef MIN_VERSION_base
12+
#define MIN_VERSION_base(major1,major2,minor) 0
13+
#endif
814
-----------------------------------------------------------------------------
915
-- |
1016
-- Module : Data.Sequence
@@ -159,12 +165,8 @@ import Text.Read (Lexeme(Ident), lexP, parens, prec,
159165
readPrec, readListPrec, readListPrecDefault)
160166
import Data.Data
161167
#endif
162-
163-
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
164-
-- Nevertheless, as a convenience, we also allow compiling without cabal by
165-
-- defining trivial MIN_VERSION_base if needed.
166-
#ifndef MIN_VERSION_base
167-
#define MIN_VERSION_base(major1,major2,minor) 0
168+
#if MIN_VERSION_base(4,8,0)
169+
import Data.Coerce
168170
#endif
169171

170172

@@ -182,11 +184,22 @@ class Sized a where
182184
newtype Seq a = Seq (FingerTree (Elem a))
183185

184186
instance Functor Seq where
185-
fmap f (Seq xs) = Seq (fmap (fmap f) xs)
187+
fmap = fmapSeq
186188
#ifdef __GLASGOW_HASKELL__
187189
x <$ s = replicate (length s) x
188190
#endif
189191

192+
fmapSeq :: (a -> b) -> Seq a -> Seq b
193+
fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
194+
#if MIN_VERSION_base(4,8,0)
195+
-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
196+
-- well enough with RULES to do what we want.
197+
{-# NOINLINE [1] fmapSeq #-}
198+
{-# RULES
199+
"fmapSeq/coerce" fmapSeq coerce = coerce
200+
#-}
201+
#endif
202+
190203
instance Foldable Seq where
191204
foldMap f (Seq xs) = foldMap (foldMap f) xs
192205
foldr f z (Seq xs) = foldr (flip (foldr f)) z xs

‎Data/Tree.hs

Lines changed: 22 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -3,8 +3,15 @@
33
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
44
#endif
55
#if __GLASGOW_HASKELL__ >= 703
6-
{-# LANGUAGE Safe #-}
6+
{-# LANGUAGE Trustworthy #-}
77
#endif
8+
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
9+
-- Nevertheless, as a convenience, we also allow compiling without cabal by
10+
-- defining trivial MIN_VERSION_base if needed.
11+
#ifndef MIN_VERSION_base
12+
#define MIN_VERSION_base(major1,major2,minor) 0
13+
#endif
14+
815
-----------------------------------------------------------------------------
916
-- |
1017
-- Module : Data.Tree
@@ -45,11 +52,8 @@ import Control.DeepSeq (NFData(rnf))
4552
import Data.Data (Data)
4653
#endif
4754

48-
-- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
49-
-- Nevertheless, as a convenience, we also allow compiling without cabal by
50-
-- defining trivial MIN_VERSION_base if needed.
51-
#ifndef MIN_VERSION_base
52-
#define MIN_VERSION_base(major1,major2,minor) 0
55+
#if MIN_VERSION_base(4,8,0)
56+
import Data.Coerce
5357
#endif
5458

5559

@@ -69,7 +73,18 @@ type Forest a = [Tree a]
6973
INSTANCE_TYPEABLE1(Tree,treeTc,"Tree")
7074

7175
instance Functor Tree where
72-
fmap f (Node x ts) = Node (f x) (map (fmap f) ts)
76+
fmap = fmapTree
77+
78+
fmapTree :: (a -> b) -> Tree a -> Tree b
79+
fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)
80+
#if MIN_VERSION_base(4,8,0)
81+
-- Safe coercions were introduced in 4.7.0, but I am not sure if they played
82+
-- well enough with RULES to do what we want.
83+
{-# NOINLINE [1] fmapTree #-}
84+
{-# RULES
85+
"fmapTree/coerce" fmapTree coerce = coerce
86+
#-}
87+
#endif
7388

7489
instance Applicative Tree where
7590
pure x = Node x []

‎tests-ghc/all.T

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,3 +5,6 @@ test('datamap001', normal, compile_and_run, ['-package containers'])
55
test('datamap002', normal, compile_and_run, ['-package containers'])
66
test('dataintset001', normal, compile_and_run, ['-package containers'])
77
test('sequence001', normal, compile_and_run, ['-package containers'])
8+
test('mapcoerceseq', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])
9+
test('mapcoercemap', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])
10+
test('mapcoercesmap', when(compiler_ge('ghc','7.9')), compile_and_run, ['-package containers'])

‎tests-ghc/mapcoercemap.hs

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
{-# LANGUAGE MagicHash #-}
2+
3+
import GHC.Exts hiding (fromList)
4+
import Unsafe.Coerce
5+
import Data.Map
6+
7+
newtype Age = Age Int
8+
9+
fooAge :: Map Int Int -> Map Int Age
10+
fooAge = fmap Age
11+
fooCoerce :: Map Int Int -> Map Int Age
12+
fooCoerce = fmap coerce
13+
fooUnsafeCoerce :: Map Int Int -> Map Int Age
14+
fooUnsafeCoerce = fmap unsafeCoerce
15+
16+
same :: a -> b -> IO ()
17+
same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
18+
1# -> putStrLn "yes"
19+
_ -> putStrLn "no"
20+
21+
main = do
22+
let l = fromList [(1,1),(2,2),(3,3)]
23+
same (fooAge l) l
24+
same (fooCoerce l) l
25+
same (fooUnsafeCoerce l) l

‎tests-ghc/mapcoercemap.stdout

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
yes
2+
yes
3+
yes

‎tests-ghc/mapcoerceseq.hs

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
{-# LANGUAGE MagicHash #-}
2+
3+
import GHC.Exts hiding (fromList)
4+
import Unsafe.Coerce
5+
import Data.Sequence
6+
7+
newtype Age = Age Int
8+
9+
fooAge :: Seq Int -> Seq Age
10+
fooAge = fmap Age
11+
fooCoerce :: Seq Int -> Seq Age
12+
fooCoerce = fmap coerce
13+
fooUnsafeCoerce :: Seq Int -> Seq Age
14+
fooUnsafeCoerce = fmap unsafeCoerce
15+
16+
same :: a -> b -> IO ()
17+
same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
18+
1# -> putStrLn "yes"
19+
_ -> putStrLn "no"
20+
21+
main = do
22+
let l = fromList [1,2,3]
23+
same (fooAge l) l
24+
same (fooCoerce l) l
25+
same (fooUnsafeCoerce l) l

‎tests-ghc/mapcoerceseq.stdout

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
yes
2+
yes
3+
yes

‎tests-ghc/mapcoercesmap.hs

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
{-# LANGUAGE MagicHash #-}
2+
3+
import GHC.Exts hiding (fromList)
4+
import Unsafe.Coerce
5+
import Data.Map.Strict
6+
7+
newtype Age = Age Int
8+
9+
fooAge :: Map Int Int -> Map Int Age
10+
fooAge = fmap Age
11+
fooCoerce :: Map Int Int -> Map Int Age
12+
fooCoerce = fmap coerce
13+
fooUnsafeCoerce :: Map Int Int -> Map Int Age
14+
fooUnsafeCoerce = fmap unsafeCoerce
15+
16+
same :: a -> b -> IO ()
17+
same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
18+
1# -> putStrLn "yes"
19+
_ -> putStrLn "no"
20+
21+
main = do
22+
let l = fromList [(1,1),(2,2),(3,3)]
23+
same (fooAge l) l
24+
same (fooCoerce l) l
25+
same (fooUnsafeCoerce l) l

0 commit comments

Comments
 (0)