Allow `gunfold' on Map, IntMap, Set, and IntSet using virtual constru…

…ctors.

* Original Proposal: http://www.haskell.org/pipermail/libraries/2012-August/018366.html

Data/IntMap/Base.hs

@@ -227,7 +227,7 @@ import Data.StrictPair
 
 #if __GLASGOW_HASKELL__
 import Text.Read
-import Data.Data (Data(..), mkNoRepType)
+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType)
 #endif
 
 #if __GLASGOW_HASKELL__
@@ -342,14 +342,22 @@ instance NFData a => NFData (IntMap a) where
 --------------------------------------------------------------------}
 
 -- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
+-- We provide limited reflection services for the sake of data abstraction.
 
 instance Data a => Data (IntMap a) where
   gfoldl f z im = z fromList `f` (toList im)
-  toConstr _    = error "toConstr"
-  gunfold _ _   = error "gunfold"
-  dataTypeOf _  = mkNoRepType "Data.IntMap.IntMap"
-  dataCast1 f   = gcast1 f
+  toConstr _     = fromListConstr
+  gunfold k z c  = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  dataTypeOf _   = intMapDataType
+  dataCast1 f    = gcast1 f
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix
+
+intMapDataType :: DataType
+intMapDataType = mkDataType "Data.IntMap.Base.IntMap" [fromListConstr]
 
 #endif
 

Data/IntSet/Base.hs

@@ -172,7 +172,7 @@ import Data.StrictPair
 
 #if __GLASGOW_HASKELL__
 import Text.Read
-import Data.Data (Data(..), mkNoRepType)
+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType)
 #endif
 
 #if __GLASGOW_HASKELL__
@@ -274,13 +274,21 @@ instance Monoid IntSet where
 --------------------------------------------------------------------}
 
 -- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
+-- We provide limited reflection services for the sake of data abstraction.
 
 instance Data IntSet where
   gfoldl f z is = z fromList `f` (toList is)
-  toConstr _    = error "toConstr"
-  gunfold _ _   = error "gunfold"
-  dataTypeOf _  = mkNoRepType "Data.IntSet.IntSet"
+  toConstr _     = fromListConstr
+  gunfold k z c  = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  dataTypeOf _   = intSetDataType
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intSetDataType "fromList" [] Prefix
+
+intSetDataType :: DataType
+intSetDataType = mkDataType "Data.IntSet.Base.IntSet" [fromListConstr]
 
 #endif
 

Data/Map/Base.hs

@@ -335,15 +335,23 @@ instance (Ord k) => Monoid (Map k v) where
 --------------------------------------------------------------------}
 
 -- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
+-- We provide limited reflection services for the sake of data abstraction.
 
 instance (Data k, Data a, Ord k) => Data (Map k a) where
   gfoldl f z m   = z fromList `f` toList m
-  toConstr _     = error "toConstr"
-  gunfold _ _    = error "gunfold"
-  dataTypeOf _   = mkNoRepType "Data.Map.Map"
+  toConstr _     = fromListConstr
+  gunfold k z c  = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  dataTypeOf _   = mapDataType
   dataCast2 f    = gcast2 f
 
+fromListConstr :: Constr
+fromListConstr = mkConstr mapDataType "fromList" [] Prefix
+
+mapDataType :: DataType
+mapDataType = mkDataType "Data.Map.Base.Map" [fromListConstr]
+
 #endif
 
 {--------------------------------------------------------------------

Data/Set/Base.hs

@@ -248,15 +248,23 @@ instance Foldable.Foldable Set where
 --------------------------------------------------------------------}
 
 -- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
+-- We provide limited reflection services for the sake of data abstraction.
 
 instance (Data a, Ord a) => Data (Set a) where
   gfoldl f z set = z fromList `f` (toList set)
-  toConstr _     = error "toConstr"
-  gunfold _ _    = error "gunfold"
-  dataTypeOf _   = mkNoRepType "Data.Set.Set"
+  toConstr _     = fromListConstr
+  gunfold k z c  = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  dataTypeOf _   = setDataType
   dataCast1 f    = gcast1 f
 
+fromListConstr :: Constr
+fromListConstr = mkConstr setDataType "fromList" [] Prefix
+
+setDataType :: DataType
+setDataType = mkDataType "Data.Set.Base.Set" [fromListConstr]
+
 #endif
 
 {--------------------------------------------------------------------