From 0d6c1599c246100deb2fa54315811ed94d1a300c Mon Sep 17 00:00:00 2001 From: ralf Date: Wed, 19 Jan 2005 22:33:36 +0000 Subject: [PATCH] [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 --- Data/Array.hs | 20 ++++++++++++++-- Data/FiniteMap.hs | 21 ++++++++++++++++ Data/Generics/Instances.hs | 57 ++++++++++++++++++++++++++++++++++++++++++++ Data/IntMap.hs | 22 +++++++++++++++++ Data/IntSet.hs | 22 +++++++++++++++++ Data/Map.hs | 22 +++++++++++++++++ Data/Set.hs | 22 +++++++++++++++++ Data/Typeable.hs | 3 ++- GHC/Conc.lhs | 11 +++++++++ GHC/ForeignPtr.hs | 4 ---- 10 files changed, 197 insertions(+), 7 deletions(-) diff --git a/Data/Array.hs b/Data/Array.hs index e8e8c76..cd41677 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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. -- 1.7.10.4