4d5837b2ff4e348f8d6475b04e3e954d0fd01ce6
[packages/base.git] / Data / Typeable / Internal.hs
1 {-# LANGUAGE Unsafe #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Data.Typeable.Internal
6 -- Copyright : (c) The University of Glasgow, CWI 2001--2011
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- The representations of the types TyCon and TypeRep, and the
10 -- function mkTyCon which is used by derived instances of Typeable to
11 -- construct a TyCon.
12 --
13 -----------------------------------------------------------------------------
14
15 {-# LANGUAGE CPP
16 , NoImplicitPrelude
17 , OverlappingInstances
18 , ScopedTypeVariables
19 , FlexibleInstances
20 , MagicHash
21 , KindSignatures
22 , PolyKinds #-}
23 #ifdef __GLASGOW_HASKELL__
24 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
25 #endif
26
27 module Data.Typeable.Internal (
28 Proxy (..),
29 TypeRep(..),
30 Fingerprint(..),
31 typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
32 TyCon(..),
33 mkTyCon,
34 mkTyCon3,
35 mkTyConApp,
36 mkAppTy,
37 typeRepTyCon,
38 Typeable(..),
39 mkFunTy,
40 splitTyConApp,
41 funResultTy,
42 typeRepArgs,
43 showsTypeRep,
44 tyConString,
45 listTc, funTc
46 ) where
47
48 import GHC.Base
49 import GHC.Word
50 import GHC.Show
51 import Data.Maybe
52 import Data.Proxy
53 import GHC.Num
54 import GHC.Real
55 -- import GHC.IORef
56 -- import GHC.IOArray
57 -- import GHC.MVar
58 import GHC.ST ( ST )
59 import GHC.STRef ( STRef )
60 import GHC.Ptr ( Ptr, FunPtr )
61 -- import GHC.Stable
62 import GHC.Arr ( Array, STArray )
63 import Data.Type.Equality
64 -- import Data.Int
65
66 import GHC.Fingerprint.Type
67 import {-# SOURCE #-} GHC.Fingerprint
68 -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
69 -- Better to break the loop here, because we want non-SOURCE imports
70 -- of Data.Typeable as much as possible so we can optimise the derived
71 -- instances.
72
73 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
74 -- supports reasonably efficient equality.
75 data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
76
77 -- Compare keys for equality
78 instance Eq TypeRep where
79 (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
80
81 instance Ord TypeRep where
82 (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2
83
84 -- | An abstract representation of a type constructor. 'TyCon' objects can
85 -- be built using 'mkTyCon'.
86 data TyCon = TyCon {
87 tyConHash :: {-# UNPACK #-} !Fingerprint,
88 tyConPackage :: String,
89 tyConModule :: String,
90 tyConName :: String
91 }
92
93 instance Eq TyCon where
94 (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
95
96 instance Ord TyCon where
97 (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
98
99 ----------------- Construction --------------------
100
101 #include "MachDeps.h"
102
103 -- mkTyCon is an internal function to make it easier for GHC to
104 -- generate derived instances. GHC precomputes the MD5 hash for the
105 -- TyCon and passes it as two separate 64-bit values to mkTyCon. The
106 -- TyCon for a derived Typeable instance will end up being statically
107 -- allocated.
108
109 #if WORD_SIZE_IN_BITS < 64
110 mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
111 #else
112 mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
113 #endif
114 mkTyCon high# low# pkg modl name
115 = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
116
117 -- | Applies a type constructor to a sequence of types
118 mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
119 mkTyConApp tc@(TyCon tc_k _ _ _) []
120 = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
121 -- end up here, and it helps generate smaller
122 -- code for derived Typeable.
123 mkTyConApp tc@(TyCon tc_k _ _ _) args
124 = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
125 where
126 arg_ks = [k | TypeRep k _ _ <- args]
127
128 -- | A special case of 'mkTyConApp', which applies the function
129 -- type constructor to a pair of types.
130 mkFunTy :: TypeRep -> TypeRep -> TypeRep
131 mkFunTy f a = mkTyConApp funTc [f,a]
132
133 -- | Splits a type constructor application
134 splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
135 splitTyConApp (TypeRep _ tc trs) = (tc,trs)
136
137 -- | Applies a type to a function type. Returns: @'Just' u@ if the
138 -- first argument represents a function of type @t -> u@ and the
139 -- second argument represents a function of type @t@. Otherwise,
140 -- returns 'Nothing'.
141 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
142 funResultTy trFun trArg
143 = case splitTyConApp trFun of
144 (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
145 _ -> Nothing
146
147 -- | Adds a TypeRep argument to a TypeRep.
148 mkAppTy :: TypeRep -> TypeRep -> TypeRep
149 mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr])
150 -- Notice that we call mkTyConApp to construct the fingerprint from tc and
151 -- the arg fingerprints. Simply combining the current fingerprint with
152 -- the new one won't give the same answer, but of course we want to
153 -- ensure that a TypeRep of the same shape has the same fingerprint!
154 -- See Trac #5962
155
156 -- | Builds a 'TyCon' object representing a type constructor. An
157 -- implementation of "Data.Typeable" should ensure that the following holds:
158 --
159 -- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
160 --
161
162 --
163 mkTyCon3 :: String -- ^ package name
164 -> String -- ^ module name
165 -> String -- ^ the name of the type constructor
166 -> TyCon -- ^ A unique 'TyCon' object
167 mkTyCon3 pkg modl name =
168 TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
169
170 ----------------- Observation ---------------------
171
172 -- | Observe the type constructor of a type representation
173 typeRepTyCon :: TypeRep -> TyCon
174 typeRepTyCon (TypeRep _ tc _) = tc
175
176 -- | Observe the argument types of a type representation
177 typeRepArgs :: TypeRep -> [TypeRep]
178 typeRepArgs (TypeRep _ _ args) = args
179
180 -- | Observe string encoding of a type representation
181 {-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-} -- deprecated in 7.4
182 tyConString :: TyCon -> String
183 tyConString = tyConName
184
185 -------------------------------------------------------------
186 --
187 -- The Typeable class and friends
188 --
189 -------------------------------------------------------------
190
191 -- | The class 'Typeable' allows a concrete representation of a type to
192 -- be calculated.
193 class Typeable a where
194 typeRep :: proxy a -> TypeRep
195 -- ^ Takes a value of type @a@ and returns a concrete representation
196 -- of that type.
197
198 -- Keeping backwards-compatibility
199 typeOf :: forall a. Typeable a => a -> TypeRep
200 typeOf _ = typeRep (Proxy :: Proxy a)
201
202 typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
203 typeOf1 _ = typeRep (Proxy :: Proxy t)
204
205 typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
206 typeOf2 _ = typeRep (Proxy :: Proxy t)
207
208 typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
209 => t a b c -> TypeRep
210 typeOf3 _ = typeRep (Proxy :: Proxy t)
211
212 typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
213 => t a b c d -> TypeRep
214 typeOf4 _ = typeRep (Proxy :: Proxy t)
215
216 typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
217 => t a b c d e -> TypeRep
218 typeOf5 _ = typeRep (Proxy :: Proxy t)
219
220 typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
221 Typeable t => t a b c d e f -> TypeRep
222 typeOf6 _ = typeRep (Proxy :: Proxy t)
223
224 typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
225 (g :: *). Typeable t => t a b c d e f g -> TypeRep
226 typeOf7 _ = typeRep (Proxy :: Proxy t)
227
228 -- | Kind-polymorphic Typeable instance for type application
229 instance (Typeable s, Typeable a) => Typeable (s a) where
230 typeRep _ = typeRep (Proxy :: Proxy s) `mkAppTy` typeRep (Proxy :: Proxy a)
231
232
233 ----------------- Showing TypeReps --------------------
234
235 instance Show TypeRep where
236 showsPrec p (TypeRep _ tycon tys) =
237 case tys of
238 [] -> showsPrec p tycon
239 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
240 [a,r] | tycon == funTc -> showParen (p > 8) $
241 showsPrec 9 a .
242 showString " -> " .
243 showsPrec 8 r
244 xs | isTupleTyCon tycon -> showTuple xs
245 | otherwise ->
246 showParen (p > 9) $
247 showsPrec p tycon .
248 showChar ' ' .
249 showArgs (showChar ' ') tys
250
251 showsTypeRep :: TypeRep -> ShowS
252 showsTypeRep = shows
253
254 instance Show TyCon where
255 showsPrec _ t = showString (tyConName t)
256
257 isTupleTyCon :: TyCon -> Bool
258 isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
259 isTupleTyCon _ = False
260
261 -- Some (Show.TypeRep) helpers:
262
263 showArgs :: Show a => ShowS -> [a] -> ShowS
264 showArgs _ [] = id
265 showArgs _ [a] = showsPrec 10 a
266 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
267
268 showTuple :: [TypeRep] -> ShowS
269 showTuple args = showChar '('
270 . showArgs (showChar ',') args
271 . showChar ')'
272
273 listTc :: TyCon
274 listTc = typeRepTyCon (typeOf [()])
275
276 funTc :: TyCon
277 funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
278
279 -------------------------------------------------------------
280 --
281 -- Instances of the Typeable classes for Prelude types
282 --
283 -------------------------------------------------------------
284
285 #include "Typeable.h"
286
287 INSTANCE_TYPEABLE0((),unitTc,"()")
288 INSTANCE_TYPEABLE1([],listTc,"[]")
289 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
290 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
291 INSTANCE_TYPEABLE2((->),funTc,"->")
292 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
293
294 #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
295 -- Types defined in GHC.MVar
296 {- INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) -}
297 #endif
298
299 INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
300 {- INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") -}
301
302 #ifdef __GLASGOW_HASKELL__
303 -- Hugs has these too, but their Typeable<n> instances are defined
304 -- elsewhere to keep this module within Haskell 98.
305 -- This is important because every invocation of runhugs or ffihugs
306 -- uses this module via Data.Dynamic.
307 INSTANCE_TYPEABLE2(ST,stTc,"ST")
308 INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
309 INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
310 #endif
311
312 INSTANCE_TYPEABLE2((,),pairTc,"(,)")
313 INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
314 INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
315 INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
316 INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
317 INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
318
319 INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
320 INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
321 #ifndef __GLASGOW_HASKELL__
322 INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
323 #endif
324 {-
325 INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
326 INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
327 -}
328
329 -------------------------------------------------------
330 --
331 -- Generate Typeable instances for standard datatypes
332 --
333 -------------------------------------------------------
334
335 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
336 INSTANCE_TYPEABLE0(Char,charTc,"Char")
337 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
338 INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
339 INSTANCE_TYPEABLE0(Int,intTc,"Int")
340 INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
341 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
342 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
343 #ifndef __GLASGOW_HASKELL__
344 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
345 #endif
346
347 {-
348 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
349 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
350 INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
351 INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
352 -}
353
354 INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
355 INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
356 INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
357 INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
358
359 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
360 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
361
362 #ifdef __GLASGOW_HASKELL__
363 deriving instance Typeable RealWorld
364 deriving instance Typeable Proxy
365 deriving instance Typeable (:=:)
366 #endif