Add kind equalities to GHC.
[ghc.git] / compiler / typecheck / TcTypeable.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
4 -}
5
6 module TcTypeable(
7 mkTypeableBinds, mkModIdBindings
8 ) where
9
10
11 import TcBinds( addTypecheckedBinds )
12 import IfaceEnv( newGlobalBinder )
13 import TcEnv
14 import TcRnMonad
15 import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
16 import Id
17 import IdInfo( IdDetails(..) )
18 import Type
19 import TyCon
20 import DataCon
21 import Name( getOccName )
22 import OccName
23 import Module
24 import HsSyn
25 import DynFlags
26 import Bag
27 import Fingerprint(Fingerprint(..), fingerprintString)
28 import Outputable
29 import Data.Word( Word64 )
30 import FastString ( FastString, mkFastString )
31
32 {- Note [Grand plan for Typeable]
33 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
34 The overall plan is this:
35
36 1. Generate a binding for each module p:M
37 (done in TcTypeable by mkModIdBindings)
38 M.$trModule :: GHC.Types.Module
39 M.$trModule = Module "p" "M"
40 ("tr" is short for "type representation"; see GHC.Types)
41
42 We might want to add the filename too.
43 This can be used for the lightweight stack-tracing stuff too
44
45 Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
46
47 2. Generate a binding for every data type declaration T in module M,
48 M.$tcT :: GHC.Types.TyCon
49 M.$tcT = TyCon ...fingerprint info...
50 $trModule
51 "T"
52 We define (in TyCon)
53 type TyConRepName = Name
54 to use for these M.$tcT "tycon rep names".
55
56 3. Record the TyConRepName in T's TyCon, including for promoted
57 data and type constructors, and kinds like * and #.
58
59 The TyConRepNaem is not an "implicit Id". It's more like a record
60 selector: the TyCon knows its name but you have to go to the
61 interface file to find its type, value, etc
62
63 4. Solve Typeable costraints. This is done by a custom Typeable solver,
64 currently in TcInteract, that use M.$tcT so solve (Typeable T).
65
66 There are many wrinkles:
67
68 * Since we generate $tcT for every data type T, the types TyCon and
69 Module must be available right from the start; so they are defined
70 in ghc-prim:GHC.Types
71
72 * To save space and reduce dependencies, we need use quite low-level
73 representations for TyCon and Module. See GHC.Types
74 Note [Runtime representation of modules and tycons]
75
76 * It's hard to generate the TyCon/Module bindings when the types TyCon
77 and Module aren't yet available; i.e. when compiling GHC.Types
78 itself. So we *don't* generate them for types in GHC.Types. Instead
79 we write them by hand in base:GHC.Typeable.Internal.
80
81 * To be able to define them by hand, they need to have user-writable
82 names, thus
83 tcBool not $tcBool for the type-rep TyCon for Bool
84 Hence PrelNames.tyConRepModOcc
85
86 * Moreover for type constructors with special syntax, they need to have
87 completely hand-crafted names
88 lists tcList not $tc[] for the type-rep TyCon for []
89 kinds tcLiftedKind not $tc* for the type-rep TyCon for *
90 Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
91 to use for the TyConRepName
92
93 * Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
94 be wired in as well. For these wired-in TyCons we generate the
95 TyConRepName's unique from that of the TyCon; see
96 Unique.tyConRepNameUnique, dataConRepNameUnique.
97
98 -}
99
100 {- *********************************************************************
101 * *
102 Building top-level binding for $trModule
103 * *
104 ********************************************************************* -}
105
106 mkModIdBindings :: TcM TcGblEnv
107 mkModIdBindings
108 = do { mod <- getModule
109 ; if mod == gHC_TYPES
110 then getGblEnv -- Do not generate bindings for modules in GHC.Types
111 else
112 do { loc <- getSrcSpanM
113 ; tr_mod_dc <- tcLookupDataCon trModuleDataConName
114 ; tr_name_dc <- tcLookupDataCon trNameSDataConName
115 ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
116 ; let mod_id = mkExportedLocalId ReflectionId mod_nm
117 (mkTyConApp (dataConTyCon tr_mod_dc) [])
118 mod_bind = mkVarBind mod_id mod_rhs
119 mod_rhs = nlHsApps (dataConWrapId tr_mod_dc)
120 [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
121 , trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
122
123 ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
124 ; return (tcg_env { tcg_tr_module = Just mod_id }
125 `addTypecheckedBinds` [unitBag mod_bind]) } }
126
127
128 {- *********************************************************************
129 * *
130 Building type-representation bindings
131 * *
132 ********************************************************************* -}
133
134 mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
135 mkTypeableBinds tycons
136 = do { dflags <- getDynFlags
137 ; gbl_env <- getGblEnv
138 ; mod <- getModule
139 ; if mod == gHC_TYPES
140 then return gbl_env -- Do not generate bindings for modules in GHC.Types
141 else
142 do { tr_datacon <- tcLookupDataCon trTyConDataConName
143 ; trn_datacon <- tcLookupDataCon trNameSDataConName
144 ; let pkg_str = unitIdString (moduleUnitId mod)
145 mod_str = moduleNameString (moduleName mod)
146 mod_expr = case tcg_tr_module gbl_env of -- Should be set by now
147 Just mod_id -> nlHsVar mod_id
148 Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
149 stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
150 all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
151 -- We need type representations for any associated types
152 tc_binds = map (mk_typeable_binds stuff) all_tycons
153 tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
154
155 ; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv
156 ; return (gbl_env `addTypecheckedBinds` tc_binds) } }
157
158 trNameLit :: DataCon -> FastString -> LHsExpr Id
159 trNameLit tr_name_dc fs
160 = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
161
162 type TypeableStuff
163 = ( DynFlags
164 , LHsExpr Id -- Of type GHC.Types.Module
165 , String -- Package name
166 , String -- Module name
167 , DataCon -- Data constructor GHC.Types.TyCon
168 , DataCon ) -- Data constructor GHC.Types.TrNameS
169
170 mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
171 mk_typeable_binds stuff tycon
172 = mkTyConRepBinds stuff tycon
173 `unionBags`
174 unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
175
176 mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
177 mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
178 = case tyConRepName_maybe tycon of
179 Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
180 where
181 rep_id = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon [])
182 _ -> emptyBag
183 where
184 tr_tycon = dataConTyCon tr_datacon
185 rep_rhs = nlHsApps (dataConWrapId tr_datacon)
186 [ nlHsLit (word64 high), nlHsLit (word64 low)
187 , mod_expr
188 , trNameLit trn_datacon (mkFastString tycon_str) ]
189
190 tycon_str = add_tick (occNameString (getOccName tycon))
191 add_tick s | isPromotedDataCon tycon = '\'' : s
192 | otherwise = s
193
194 hashThis :: String
195 hashThis = unwords [pkg_str, mod_str, tycon_str]
196
197 Fingerprint high low
198 | gopt Opt_SuppressUniques dflags = Fingerprint 0 0
199 | otherwise = fingerprintString hashThis
200
201 word64 :: Word64 -> HsLit
202 word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
203 | otherwise = \n -> HsWordPrim (show n) (toInteger n)
204
205 mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
206 mkTypeableDataConBinds stuff dc
207 = mkTyConRepBinds stuff (promoteDataCon dc)