From: Ian Lynagh Date: Sun, 24 Apr 2011 18:16:52 +0000 (+0100) Subject: For GHC, implement the Typeable.hs macros using standalone deriving X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=commitdiff_plain;h=4475dcabbc206d1cf0fc3fee88f600a4791d948c For GHC, implement the Typeable.hs macros using standalone deriving As well as being more pleasant, this fixes #1841: Data.Typeable: Instances of basic types don't provide qualified strings to mkTyCon --- diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs index 2255c4e..d6be913 100644 --- a/Control/Concurrent/Chan.hs +++ b/Control/Concurrent/Chan.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs index 22f6c0c..6b9a059 100644 --- a/Control/Concurrent/QSem.hs +++ b/Control/Concurrent/QSem.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs index cfcff7f..43fe288 100644 --- a/Control/Concurrent/QSemN.hs +++ b/Control/Concurrent/QSemN.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs index ca68a38..615a0bf 100644 --- a/Control/Concurrent/SampleVar.hs +++ b/Control/Concurrent/SampleVar.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index cb5321b..a5d72ce 100644 --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif #include "Typeable.h" diff --git a/Control/OldException.hs b/Control/OldException.hs index 0284899..6442d67 100644 --- a/Control/OldException.hs +++ b/Control/OldException.hs @@ -3,6 +3,9 @@ , ForeignFunctionInterface , ExistentialQuantification #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif #include "Typeable.h" diff --git a/Data/Complex.hs b/Data/Complex.hs index 9765eda..9ea8a41 100644 --- a/Data/Complex.hs +++ b/Data/Complex.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs index b83bbfa..df64c38 100644 --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, NoImplicitPrelude #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Data/Either.hs b/Data/Either.hs index 1c12897..b45609b 100644 --- a/Data/Either.hs +++ b/Data/Either.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, NoImplicitPrelude #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/Data/Typeable.hs b/Data/Typeable.hs index 804e853..ce602e4 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -6,6 +6,9 @@ , FlexibleInstances #-} {-# OPTIONS_GHC -funbox-strict-fields #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif -- The -XOverlappingInstances flag allows the user to over-ride -- the instances for Typeable given here. In particular, we provide an instance @@ -577,9 +580,26 @@ gcast2 x = r INSTANCE_TYPEABLE0((),unitTc,"()") INSTANCE_TYPEABLE1([],listTc,"[]") +#if defined(__GLASGOW_HASKELL__) +listTc :: TyCon +listTc = typeRepTyCon (typeOf [()]) +#endif INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") +#if defined(__GLASGOW_HASKELL__) +{- +TODO: Deriving this instance fails with: +libraries/base/Data/Typeable.hs:589:1: + Can't make a derived instance of `Typeable2 (->)': + The last argument of the instance must be a data or newtype application + In the stand-alone deriving instance for `Typeable2 (->)' +-} +instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] } +funTc :: TyCon +funTc = mkTyCon "->" +#else INSTANCE_TYPEABLE2((->),funTc,"->") +#endif INSTANCE_TYPEABLE1(IO,ioTc,"IO") #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) @@ -651,7 +671,17 @@ INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") #ifdef __GLASGOW_HASKELL__ -INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld") +{- +TODO: This can't be derived currently: +libraries/base/Data/Typeable.hs:674:1: + Can't make a derived instance of `Typeable RealWorld': + The last argument of the instance must be a data or newtype application + In the stand-alone deriving instance for `Typeable RealWorld' +-} +realWorldTc :: TyCon; \ +realWorldTc = mkTyCon "GHC.Base.RealWorld"; \ +instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] } + #endif --------------------------------------------- diff --git a/Foreign/C/Types.hs b/Foreign/C/Types.hs index 22bae5c..98113c8 100644 --- a/Foreign/C/Types.hs +++ b/Foreign/C/Types.hs @@ -4,6 +4,9 @@ , GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif -- XXX -fno-warn-unused-binds stops us warning about unused constructors, -- but really we should just remove them if we don't want them @@ -91,7 +94,7 @@ import Foreign.Storable import Data.Bits ( Bits(..) ) import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.Word ( Word8, Word16, Word32, Word64 ) -import {-# SOURCE #-} Data.Typeable (Typeable(typeOf), TyCon, mkTyCon, mkTyConApp) +import {-# SOURCE #-} Data.Typeable #ifdef __GLASGOW_HASKELL__ import GHC.Base diff --git a/Foreign/Ptr.hs b/Foreign/Ptr.hs index b46acc1..26dda5c 100644 --- a/Foreign/Ptr.hs +++ b/Foreign/Ptr.hs @@ -4,6 +4,9 @@ , MagicHash , GeneralizedNewtypeDeriving #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs index af69a63..0214a56 100644 --- a/GHC/Conc/Sync.lhs +++ b/GHC/Conc/Sync.lhs @@ -7,6 +7,7 @@ , UnliftedFFITypes , ForeignFunctionInterface , DeriveDataTypeable + , StandaloneDeriving , RankNTypes #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs index 2e737f0..dbf6c2c 100644 --- a/GHC/ForeignPtr.hs +++ b/GHC/ForeignPtr.hs @@ -5,6 +5,7 @@ , UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | diff --git a/GHC/Weak.lhs b/GHC/Weak.lhs index 67046f8..92e1eb8 100644 --- a/GHC/Weak.lhs +++ b/GHC/Weak.lhs @@ -4,6 +4,8 @@ , BangPatterns , MagicHash , UnboxedTuples + , DeriveDataTypeable + , StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} diff --git a/System/Mem/StableName.hs b/System/Mem/StableName.hs index d7d27a3..2bce839 100644 --- a/System/Mem/StableName.hs +++ b/System/Mem/StableName.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} #ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} {-# LANGUAGE MagicHash #-} #if !defined(__PARALLEL_HASKELL__) {-# LANGUAGE UnboxedTuples #-} diff --git a/System/Posix/Types.hs b/System/Posix/Types.hs index 676fead..d5d26c6 100644 --- a/System/Posix/Types.hs +++ b/System/Posix/Types.hs @@ -4,6 +4,9 @@ , GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/System/Timeout.hs b/System/Timeout.hs index dbd7181..df33625 100644 --- a/System/Timeout.hs +++ b/System/Timeout.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif ------------------------------------------------------------------------------- -- | diff --git a/include/Typeable.h b/include/Typeable.h index e9a6c7a..38fe90f 100644 --- a/include/Typeable.h +++ b/include/Typeable.h @@ -14,52 +14,26 @@ #ifndef TYPEABLE_H #define TYPEABLE_H -#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } - #ifdef __GLASGOW_HASKELL__ --- // For GHC, the extra instances follow from general instance declarations --- // defined in Data.Typeable. +-- // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to +-- // generate the instances. -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } +#define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon +#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon +#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon +#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon +#define INSTANCE_TYPEABLE4(tycon,tcname,str) deriving instance Typeable4 tycon +#define INSTANCE_TYPEABLE5(tycon,tcname,str) deriving instance Typeable5 tycon +#define INSTANCE_TYPEABLE6(tycon,tcname,str) deriving instance Typeable6 tycon +#define INSTANCE_TYPEABLE7(tycon,tcname,str) deriving instance Typeable7 tycon -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE4(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE5(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE6(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] } +#else /* !__GLASGOW_HASKELL__ */ -#define INSTANCE_TYPEABLE7(tycon,tcname,str) \ +#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \ -instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] } - -#else /* !__GLASGOW_HASKELL__ */ +instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname = mkTyCon str; \