[project @ 2005-01-19 22:33:32 by ralf]

Added quite a few more Data instances.

For these datatypes:

- Data.Array
- Data.FiniteMap
- Data.IntMap
- Data.IntSet
- Data.Map
- Data.Set
- GHC.ST
- GHC.ForeignPtr
- Control.Concurrent.MVar and friends

(In some cases, this also required adding Typeable instances.)

Most or all additions have been tagged by
#ifdef __GLASGOW_HASKELL__ ...

For the _abstract_ datatypes in the above list,
we use the from... and to... projections and injections
so that we can process the containers or whatever as lists.
We don't provide the reflection API for abstract datatypes.

If anyone sees Data-wanting datatypes in the base or elsewhere
in the module space, please let me know, or please go ahead,
and add coverage for SYB. As far as I understand, the base
code cannot use "deriving (Typeable, Data)", whereas this
is very well an option for non-base modules. Indeed it is
readily done like this in:
- network/Network/URI
- haskell-src

diff --git a/Data/Array.hs b/Data/Array.hs
index e8e8c76..cd41677 100644 (file)
--- a/Data/Array.hs
+++ b/Data/Array.hs
@@ -58,8 +58,10 @@ module  Data.Array
 import Data.Ix
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Arr         -- Most of the hard work is done here
-import GHC.Err         ( undefined )
+import GHC.Arr                 -- Most of the hard work is done here
+import Data.Generics.Basics     -- To provide a Data instance
+import Data.Generics.Instances  -- To provide a Data instance
+import GHC.Err ( error )        -- Needed for Data instance
 #endif
 
 #ifdef __HUGS__
@@ -79,6 +81,20 @@ import Data.Typeable
 INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
 #endif
 
+#ifdef __GLASGOW_HASKELL__
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit reflection services for the sake of data abstraction.
+
+instance (Typeable a, Data b, Ix a) => Data (Array a b)
+ where
+  gfoldl f z a = z (listArray (bounds a)) `f` (elems a)
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Data.Array.Array"
+
+#endif
+
 {- $intro
 Haskell provides indexable /arrays/, which may be thought of as functions
 whose domains are isomorphic to contiguous subsets of the integers.

diff --git a/Data/FiniteMap.hs b/Data/FiniteMap.hs
index f8d0826..d927917 100644 (file)
--- a/Data/FiniteMap.hs
+++ b/Data/FiniteMap.hs
@@ -93,6 +93,9 @@ import Prelude -- necessary to get dependencies right
 import Data.Maybe ( isJust )
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
+import Data.Typeable
+import Data.Generics.Basics
+import Data.Generics.Instances
 #endif
 
 #ifdef __HADDOCK__
@@ -121,6 +124,7 @@ import Bag  ( foldBag )
 #endif /* not GHC */
 
 
+
 -- ---------------------------------------------------------------------------
 -- The signature of the module
 
@@ -289,6 +293,23 @@ instance (Show k, Show e) => Show (FiniteMap k e) where
 instance Functor (FiniteMap k) where
   fmap f = mapFM (const f)
 
+#if __GLASGOW_HASKELL__
+
+#include "Typeable.h"
+INSTANCE_TYPEABLE2(FiniteMap,arrayTc,"FiniteMap")
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit reflection services for the sake of data abstraction.
+
+instance (Data a, Data b, Ord a) => Data (FiniteMap a b) where
+  gfoldl f z fm = z listToFM `f` (fmToList fm)
+  toConstr _    = error "toConstr"
+  gunfold _ _   = error "gunfold"
+  dataTypeOf _  = mkNorepType "Data.Array.Array"
+
+#endif
+
+
 -- ---------------------------------------------------------------------------
 -- Adding to and deleting from @FiniteMaps@
 

diff --git a/Data/Generics/Instances.hs b/Data/Generics/Instances.hs
index f6e3be0..1157dc5 100644 (file)
--- a/Data/Generics/Instances.hs
+++ b/Data/Generics/Instances.hs
@@ -34,7 +34,10 @@ import Data.Word             -- So we can give Data instance for Word8, ...
 import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio
 import GHC.IOBase           -- So we can give Data instance for IO, Handle
 import GHC.Ptr              -- So we can give Data instance for Ptr
+import GHC.ForeignPtr       -- So we can give Data instance for ForeignPtr
 import GHC.Stable           -- So we can give Data instance for StablePtr
+import GHC.ST               -- So we can give Data instance for ST
+import GHC.Conc                     -- So we can give Data instance for MVar & Co.
 
 #include "Typeable.h"
 
@@ -548,3 +551,57 @@ instance Typeable a => Data (IORef a) where
 
 
 ------------------------------------------------------------------------------
+
+
+instance Typeable a => Data (ForeignPtr a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "GHC.ForeignPtr.ForeignPtr"
+
+
+------------------------------------------------------------------------------
+
+
+instance (Typeable s, Typeable a) => Data (ST s a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "GHC.ST.ST"
+
+
+------------------------------------------------------------------------------
+
+
+instance Data ThreadId where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "GHC.Conc.ThreadId"
+
+
+------------------------------------------------------------------------------
+
+
+instance Typeable a => Data (TVar a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "GHC.Conc.TVar"
+
+
+------------------------------------------------------------------------------
+
+
+instance Typeable a => Data (MVar a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "GHC.Conc.MVar"
+
+
+------------------------------------------------------------------------------
+
+
+instance Typeable a => Data (STM a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "GHC.Conc.STM"
+
+
+------------------------------------------------------------------------------

diff --git a/Data/IntMap.hs b/Data/IntMap.hs
index 41d9ba2..46c6bee 100644 (file)
--- a/Data/IntMap.hs
+++ b/Data/IntMap.hs
@@ -147,6 +147,11 @@ import List (nub,sort)
 import qualified List
 -}  
 
+#if __GLASGOW_HASKELL__
+import Data.Generics.Basics
+import Data.Generics.Instances
+#endif
+
 #if __GLASGOW_HASKELL__ >= 503
 import GHC.Word
 import GHC.Exts ( Word(..), Int(..), shiftRL# )
@@ -205,6 +210,23 @@ type Mask   = Int
 type Key    = Int
 
 {--------------------------------------------------------------------
+  A Data instance  
+--------------------------------------------------------------------}
+
+#if __GLASGOW_HASKELL__
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit 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"
+
+#endif
+
+{--------------------------------------------------------------------
   Query
 --------------------------------------------------------------------}
 -- | /O(1)/. Is the map empty?

diff --git a/Data/IntSet.hs b/Data/IntSet.hs
index 1d46218..e06c6da 100644 (file)
--- a/Data/IntSet.hs
+++ b/Data/IntSet.hs
@@ -104,6 +104,11 @@ import List (nub,sort)
 import qualified List
 -}
 
+#if __GLASGOW_HASKELL__
+import Data.Generics.Basics
+import Data.Generics.Instances
+#endif
+
 #if __GLASGOW_HASKELL__ >= 503
 import GHC.Word
 import GHC.Exts ( Word(..), Int(..), shiftRL# )
@@ -155,6 +160,23 @@ type Prefix = Int
 type Mask   = Int
 
 {--------------------------------------------------------------------
+  A Data instance  
+--------------------------------------------------------------------}
+
+#if __GLASGOW_HASKELL__
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit 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"
+
+#endif
+
+{--------------------------------------------------------------------
   Query
 --------------------------------------------------------------------}
 -- | /O(1)/. Is the set empty?

diff --git a/Data/Map.hs b/Data/Map.hs
index 4635bf4..9e78149 100644 (file)
--- a/Data/Map.hs
+++ b/Data/Map.hs
@@ -161,6 +161,11 @@ import Debug.QuickCheck
 import List(nub,sort)    
 -}
 
+#if __GLASGOW_HASKELL__
+import Data.Generics.Basics
+import Data.Generics.Instances
+#endif
+
 {--------------------------------------------------------------------
   Operators
 --------------------------------------------------------------------}
@@ -184,6 +189,23 @@ data Map k a  = Tip
 type Size     = Int
 
 {--------------------------------------------------------------------
+  A Data instance  
+--------------------------------------------------------------------}
+
+#if __GLASGOW_HASKELL__
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit reflection services for the sake of data abstraction.
+
+instance (Data k, Data a, Ord k) => Data (Map k a) where
+  gfoldl f z map = z fromList `f` (toList map)
+  toConstr _     = error "toConstr"
+  gunfold _ _    = error "gunfold"
+  dataTypeOf _   = mkNorepType "Data.Map.Map"
+
+#endif
+
+{--------------------------------------------------------------------
   Query
 --------------------------------------------------------------------}
 -- | /O(1)/. Is the map empty?

diff --git a/Data/Set.hs b/Data/Set.hs
index 8376f25..b357f96 100644 (file)
--- a/Data/Set.hs
+++ b/Data/Set.hs
@@ -123,6 +123,11 @@ import List (nub,sort)
 import qualified List
 -}
 
+#if __GLASGOW_HASKELL__
+import Data.Generics.Basics
+import Data.Generics.Instances
+#endif
+
 {--------------------------------------------------------------------
   Operators
 --------------------------------------------------------------------}
@@ -142,6 +147,23 @@ data Set a    = Tip
 type Size     = Int
 
 {--------------------------------------------------------------------
+  A Data instance  
+--------------------------------------------------------------------}
+
+#if __GLASGOW_HASKELL__
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit 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"
+
+#endif
+
+{--------------------------------------------------------------------
   Query
 --------------------------------------------------------------------}
 -- | /O(1)/. Is this the empty set?

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index 2369b80..efb020e 100644 (file)
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -98,6 +98,7 @@ import GHC.Real( rem, Ratio )
 import GHC.IOBase
 import GHC.ST          -- So we can give Typeable instance for ST
 import GHC.Ptr          -- So we can give Typeable instance for Ptr
+import GHC.ForeignPtr   -- So we can give Typeable instance for ForeignPtr
 import GHC.Stable       -- So we can give Typeable instance for StablePtr
 #endif
 
@@ -466,6 +467,7 @@ INSTANCE_TYPEABLE2((->),funTc,"->")
 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
 #ifdef __GLASGOW_HASKELL__
 INSTANCE_TYPEABLE2(ST,stTc,"ST")
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
 #endif
 INSTANCE_TYPEABLE0((),unitTc,"()")
 #ifndef __NHC__
@@ -534,7 +536,6 @@ INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
 
 #ifdef __GLASGOW_HASKELL__
 INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
-INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
 #endif
 
 ---------------------------------------------

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 02b256a..edb9679 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -81,6 +81,8 @@ import GHC.Exception    ( Exception(..), AsyncException(..) )
 import GHC.Pack                ( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
+import Data.Typeable
+#include "Typeable.h"
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -114,6 +116,9 @@ This misfeature will hopefully be corrected at a later date.
 it defines 'ThreadId' as a synonym for ().
 -}
 
+INSTANCE_TYPEABLE0(ThreadId,threadIdTc,"ThreadId")
+
+
 --forkIO has now been hoisted out into the Concurrent library.
 
 {- | 'killThread' terminates the given thread (GHC only).
@@ -204,6 +209,8 @@ transactions.
 \begin{code}
 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
 
+INSTANCE_TYPEABLE1(STM,stmTc,"STM" )
+
 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
 unSTM (STM a) = a
 
@@ -262,6 +269,8 @@ catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
 
 data TVar a = TVar (TVar# RealWorld a)
 
+INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar" )
+
 instance Eq (TVar a) where
        (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
 
@@ -300,6 +309,8 @@ writes.
 \begin{code}
 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 
+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+
 -- |Create an 'MVar' which is initially empty.
 newEmptyMVar  :: IO (MVar a)
 newEmptyMVar = IO $ \ s# ->

diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs
index fac4461..f6a61c1 100644 (file)
--- a/GHC/ForeignPtr.hs
+++ b/GHC/ForeignPtr.hs
@@ -32,7 +32,6 @@ module GHC.ForeignPtr
 import Control.Monad   ( sequence_ )
 import Foreign.Ptr
 import Foreign.Storable
-import Data.Typeable
 
 import GHC.List        ( null )
 import GHC.Base
@@ -70,9 +69,6 @@ instance Ord (ForeignPtr a) where
 instance Show (ForeignPtr a) where
     showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
 
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
-
 -- |A Finalizer is represented as a pointer to a foreign function that, at
 -- finalisation time, gets as an argument a plain pointer variant of the
 -- foreign pointer that the finalizer is associated with.