@@ -1,33 +1,40 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE InstanceSigs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MagicHash #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE ViewPatterns #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE KindSignatures #-}
8+{-# LANGUAGE MagicHash #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE Rank2Types #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeInType #-}
13+{-# LANGUAGE ViewPatterns #-}
14+
15+#if __GLASGOW_HASKELL__ >= 806
16+{-# LANGUAGE QuantifiedConstraints #-}
17+#endif
1318
1419-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-}
1520
16−-- | Internal API for 'TypeRepMap' and operations on it. The functions here do
17−-- not have any stability guarantees and can change between minor versions.
18−--
19−-- If you need to use this module for purposes other than tests,
20−-- create an issue.
21−--
21+{- | Internal API for 'TypeRepMap' and operations on it. The functions here do
22+not have any stability guarantees and can change between minor versions.
23+
24+If you need to use this module for purposes other than tests,
25+create an issue.
26+-}
27+
2228module Data.TypeRepMap.Internal where
2329
2430import Prelude hiding (lookup)
2531
32+import Control.DeepSeq
2633import Control.Monad.ST (ST, runST)
2734import Control.Monad.Zip (mzip)
28−import Control.DeepSeq
2935import Data.Function (on)
3036import Data.Kind (Type)
37+import Data.Type.Equality ((:~:) (..), TestEquality (..))
3138import Data.List (intercalate, nubBy)
3239import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,
3340 thawArray, unsafeFreezeArray, writeArray)
@@ -97,6 +104,31 @@ instance Monoid (TypeRepMap f) where
97104 {-# INLINE mempty #-}
98105 {-# INLINE mappend #-}
99106
107+#if __GLASGOW_HASKELL__ >= 806
108+instance (forall a. Typeable a => Eq (f a)) => Eq (TypeRepMap f) where
109+ tm1 == tm2 = size tm1 == size tm2 && go 0
110+ where
111+ go :: Int -> Bool
112+ go i
113+ | i == size tm1 = True
114+ | otherwise = case testEquality tr1i tr2i of
115+ Nothing -> False
116+ Just Refl -> repEq tr1i (fromAny tv1i) (fromAny tv2i) && go (i + 1)
117+ where
118+ tr1i :: TypeRep x
119+ tr1i = anyToTypeRep $ indexArray (trKeys tm1) i
120+
121+ tr2i :: TypeRep y
122+ tr2i = anyToTypeRep $ indexArray (trKeys tm2) i
123+
124+ tv1i, tv2i :: Any
125+ tv1i = indexArray (trAnys tm1) i
126+ tv2i = indexArray (trAnys tm2) i
127+
128+ repEq :: TypeRep x -> f x -> f x -> Bool
129+ repEq tr = withTypeable tr (==)
130+#endif
131+
100132-- | Returns the list of 'Fingerprint's from 'TypeRepMap'.
101133toFingerprints :: TypeRepMap f -> [Fingerprint]
102134toFingerprints TypeRepMap{..} =