e35d794a62483ae565b2fd0f98a51420c55e5826
[ghc.git] / libraries / base / Data / Typeable / Internal.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE BangPatterns #-}
3 {-# LANGUAGE CPP #-}
4 {-# LANGUAGE ConstraintKinds #-}
5 {-# LANGUAGE DataKinds #-}
6 {-# LANGUAGE FlexibleInstances #-}
7 {-# LANGUAGE MagicHash #-}
8 {-# LANGUAGE NoImplicitPrelude #-}
9 {-# LANGUAGE PolyKinds #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE StandaloneDeriving #-}
12 {-# LANGUAGE UndecidableInstances #-}
13
14 -----------------------------------------------------------------------------
15 -- |
16 -- Module : Data.Typeable.Internal
17 -- Copyright : (c) The University of Glasgow, CWI 2001--2011
18 -- License : BSD-style (see the file libraries/base/LICENSE)
19 --
20 -- The representations of the types TyCon and TypeRep, and the
21 -- function mkTyCon which is used by derived instances of Typeable to
22 -- construct a TyCon.
23 --
24 -----------------------------------------------------------------------------
25
26 module Data.Typeable.Internal (
27 Proxy (..),
28 TypeRep(..),
29 KindRep,
30 Fingerprint(..),
31 typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
32 Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
33 TyCon(..),
34 typeRep,
35 mkTyCon,
36 mkTyCon3,
37 mkTyConApp,
38 mkPolyTyConApp,
39 mkAppTy,
40 typeRepTyCon,
41 Typeable(..),
42 mkFunTy,
43 splitTyConApp,
44 splitPolyTyConApp,
45 funResultTy,
46 typeRepArgs,
47 typeRepFingerprint,
48 rnfTypeRep,
49 showsTypeRep,
50 tyConString,
51 rnfTyCon,
52 listTc, funTc,
53 typeRepKinds,
54 typeNatTypeRep,
55 typeSymbolTypeRep
56 ) where
57
58 import GHC.Base
59 import GHC.Word
60 import GHC.Show
61 import GHC.TypeLits
62 import Data.Proxy
63
64 import GHC.Fingerprint.Type
65 import {-# SOURCE #-} GHC.Fingerprint
66 -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
67 -- Better to break the loop here, because we want non-SOURCE imports
68 -- of Data.Typeable as much as possible so we can optimise the derived
69 -- instances.
70
71 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
72 -- supports reasonably efficient equality.
73 data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep]
74
75 type KindRep = TypeRep
76
77 -- Compare keys for equality
78 instance Eq TypeRep where
79 TypeRep x _ _ _ == TypeRep y _ _ _ = x == y
80
81 instance Ord TypeRep where
82 TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y
83
84
85 -- | An abstract representation of a type constructor. 'TyCon' objects can
86 -- be built using 'mkTyCon'.
87 data TyCon = TyCon {
88 tyConFingerprint :: {-# UNPACK #-} !Fingerprint, -- ^ @since 4.8.0.0
89 tyConPackage :: String, -- ^ @since 4.5.0.0
90 tyConModule :: String, -- ^ @since 4.5.0.0
91 tyConName :: String -- ^ @since 4.5.0.0
92 }
93
94 instance Eq TyCon where
95 (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
96
97 instance Ord TyCon where
98 (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
99
100 ----------------- Construction --------------------
101
102 #include "MachDeps.h"
103
104 -- mkTyCon is an internal function to make it easier for GHC to
105 -- generate derived instances. GHC precomputes the MD5 hash for the
106 -- TyCon and passes it as two separate 64-bit values to mkTyCon. The
107 -- TyCon for a derived Typeable instance will end up being statically
108 -- allocated.
109
110 #if WORD_SIZE_IN_BITS < 64
111 mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
112 #else
113 mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
114 #endif
115 mkTyCon high# low# pkg modl name
116 = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
117
118 -- | Applies a polymorhic type constructor to a sequence of kinds and types
119 mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
120 mkPolyTyConApp tc@(TyCon tc_k _ _ _) [] [] = TypeRep tc_k tc [] []
121 mkPolyTyConApp tc@(TyCon tc_k _ _ _) kinds types =
122 TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc kinds types
123 where
124 arg_ks = [ k | TypeRep k _ _ _ <- kinds ++ types ]
125
126 -- | Applies a monomorphic type constructor to a sequence of types
127 mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
128 mkTyConApp tc = mkPolyTyConApp tc []
129
130 -- | A special case of 'mkTyConApp', which applies the function
131 -- type constructor to a pair of types.
132 mkFunTy :: TypeRep -> TypeRep -> TypeRep
133 mkFunTy f a = mkTyConApp funTc [f,a]
134
135 -- | Splits a type constructor application.
136 -- Note that if the type construcotr is polymorphic, this will
137 -- not return the kinds that were used.
138 -- See 'splitPolyTyConApp' if you need all parts.
139 splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
140 splitTyConApp (TypeRep _ tc _ trs) = (tc,trs)
141
142 -- | Split a type constructor application
143 splitPolyTyConApp :: TypeRep -> (TyCon,[KindRep],[TypeRep])
144 splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs)
145
146 -- | Applies a type to a function type. Returns: @'Just' u@ if the
147 -- first argument represents a function of type @t -> u@ and the
148 -- second argument represents a function of type @t@. Otherwise,
149 -- returns 'Nothing'.
150 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
151 funResultTy trFun trArg
152 = case splitTyConApp trFun of
153 (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
154 _ -> Nothing
155
156 -- | Adds a TypeRep argument to a TypeRep.
157 mkAppTy :: TypeRep -> TypeRep -> TypeRep
158 mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
159 -- Notice that we call mkTyConApp to construct the fingerprint from tc and
160 -- the arg fingerprints. Simply combining the current fingerprint with
161 -- the new one won't give the same answer, but of course we want to
162 -- ensure that a TypeRep of the same shape has the same fingerprint!
163 -- See Trac #5962
164
165 -- | Builds a 'TyCon' object representing a type constructor. An
166 -- implementation of "Data.Typeable" should ensure that the following holds:
167 --
168 -- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
169 --
170
171 --
172 mkTyCon3 :: String -- ^ package name
173 -> String -- ^ module name
174 -> String -- ^ the name of the type constructor
175 -> TyCon -- ^ A unique 'TyCon' object
176 mkTyCon3 pkg modl name =
177 TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
178
179 ----------------- Observation ---------------------
180
181 -- | Observe the type constructor of a type representation
182 typeRepTyCon :: TypeRep -> TyCon
183 typeRepTyCon (TypeRep _ tc _ _) = tc
184
185 -- | Observe the argument types of a type representation
186 typeRepArgs :: TypeRep -> [TypeRep]
187 typeRepArgs (TypeRep _ _ _ tys) = tys
188
189 -- | Observe the argument kinds of a type representation
190 typeRepKinds :: TypeRep -> [KindRep]
191 typeRepKinds (TypeRep _ _ ks _) = ks
192
193 -- | Observe string encoding of a type representation
194 {-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} -- deprecated in 7.4
195 tyConString :: TyCon -> String
196 tyConString = tyConName
197
198 -- | Observe the 'Fingerprint' of a type representation
199 --
200 -- @since 4.8.0.0
201 typeRepFingerprint :: TypeRep -> Fingerprint
202 typeRepFingerprint (TypeRep fpr _ _ _) = fpr
203
204 -------------------------------------------------------------
205 --
206 -- The Typeable class and friends
207 --
208 -------------------------------------------------------------
209
210 -- | The class 'Typeable' allows a concrete representation of a type to
211 -- be calculated.
212 class Typeable a where
213 typeRep# :: Proxy# a -> TypeRep
214
215 -- | Takes a value of type @a@ and returns a concrete representation
216 -- of that type.
217 --
218 -- @since 4.7.0.0
219 typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
220 typeRep _ = typeRep# (proxy# :: Proxy# a)
221 {-# INLINE typeRep #-}
222
223 -- Keeping backwards-compatibility
224 typeOf :: forall a. Typeable a => a -> TypeRep
225 typeOf _ = typeRep (Proxy :: Proxy a)
226
227 typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
228 typeOf1 _ = typeRep (Proxy :: Proxy t)
229
230 typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
231 typeOf2 _ = typeRep (Proxy :: Proxy t)
232
233 typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
234 => t a b c -> TypeRep
235 typeOf3 _ = typeRep (Proxy :: Proxy t)
236
237 typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
238 => t a b c d -> TypeRep
239 typeOf4 _ = typeRep (Proxy :: Proxy t)
240
241 typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
242 => t a b c d e -> TypeRep
243 typeOf5 _ = typeRep (Proxy :: Proxy t)
244
245 typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
246 Typeable t => t a b c d e f -> TypeRep
247 typeOf6 _ = typeRep (Proxy :: Proxy t)
248
249 typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
250 (g :: *). Typeable t => t a b c d e f g -> TypeRep
251 typeOf7 _ = typeRep (Proxy :: Proxy t)
252
253 type Typeable1 (a :: * -> *) = Typeable a
254 type Typeable2 (a :: * -> * -> *) = Typeable a
255 type Typeable3 (a :: * -> * -> * -> *) = Typeable a
256 type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a
257 type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a
258 type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a
259 type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a
260
261 {-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8
262 {-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8
263 {-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8
264 {-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8
265 {-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8
266 {-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8
267 {-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8
268
269
270 ----------------- Showing TypeReps --------------------
271
272 instance Show TypeRep where
273 showsPrec p (TypeRep _ tycon kinds tys) =
274 case tys of
275 [] -> showsPrec p tycon
276 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
277 [a,r] | tycon == funTc -> showParen (p > 8) $
278 showsPrec 9 a .
279 showString " -> " .
280 showsPrec 8 r
281 xs | isTupleTyCon tycon -> showTuple xs
282 | otherwise ->
283 showParen (p > 9) $
284 showsPrec p tycon .
285 showChar ' ' .
286 showArgs (showChar ' ') (kinds ++ tys)
287
288 showsTypeRep :: TypeRep -> ShowS
289 showsTypeRep = shows
290
291 instance Show TyCon where
292 showsPrec _ t = showString (tyConName t)
293
294 isTupleTyCon :: TyCon -> Bool
295 isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
296 isTupleTyCon _ = False
297
298 -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
299 --
300 -- @since 4.8.0.0
301 rnfTypeRep :: TypeRep -> ()
302 rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs
303 where
304 go [] = ()
305 go (x:xs) = rnfTypeRep x `seq` go xs
306
307 -- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
308 --
309 -- @since 4.8.0.0
310 rnfTyCon :: TyCon -> ()
311 rnfTyCon (TyCon _ tcp tcm tcn) = go tcp `seq` go tcm `seq` go tcn
312 where
313 go [] = ()
314 go (x:xs) = x `seq` go xs
315
316 -- Some (Show.TypeRep) helpers:
317
318 showArgs :: Show a => ShowS -> [a] -> ShowS
319 showArgs _ [] = id
320 showArgs _ [a] = showsPrec 10 a
321 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
322
323 showTuple :: [TypeRep] -> ShowS
324 showTuple args = showChar '('
325 . showArgs (showChar ',') args
326 . showChar ')'
327
328 listTc :: TyCon
329 listTc = typeRepTyCon (typeOf [()])
330
331 funTc :: TyCon
332 funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
333
334
335 -- | Used to make `'Typeable' instance for things of kind Nat
336 typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
337 typeNatTypeRep p = typeLitTypeRep (show (natVal' p))
338
339 -- | Used to make `'Typeable' instance for things of kind Symbol
340 typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
341 typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
342
343 -- | An internal function, to make representations for type literals.
344 typeLitTypeRep :: String -> TypeRep
345 typeLitTypeRep nm = rep
346 where
347 rep = mkTyConApp tc []
348 tc = TyCon
349 { tyConFingerprint = fingerprintString (mk pack modu nm)
350 , tyConPackage = pack
351 , tyConModule = modu
352 , tyConName = nm
353 }
354 pack = "base"
355 modu = "GHC.TypeLits"
356 mk a b c = a ++ " " ++ b ++ " " ++ c
357
358