Typos in comments only [ci skip]
[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 {-# LANGUAGE RecordWildCards #-}
7
8 module TcTypeable(mkTypeableBinds) where
9
10
11 import BasicTypes ( SourceText(..) )
12 import TcBinds( addTypecheckedBinds )
13 import IfaceEnv( newGlobalBinder )
14 import TcEnv
15 import TcRnMonad
16 import PrelNames
17 import TysPrim ( primTyCons )
18 import Id
19 import Type
20 import TyCon
21 import DataCon
22 import Name( getOccName )
23 import OccName
24 import Module
25 import HsSyn
26 import DynFlags
27 import Bag
28 import Fingerprint(Fingerprint(..), fingerprintString)
29 import Outputable
30 import FastString ( FastString, mkFastString )
31
32 import Data.Word( Word64 )
33
34 {- Note [Grand plan for Typeable]
35 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
36 The overall plan is this:
37
38 1. Generate a binding for each module p:M
39 (done in TcTypeable by mkModIdBindings)
40 M.$trModule :: GHC.Types.Module
41 M.$trModule = Module "p" "M"
42 ("tr" is short for "type representation"; see GHC.Types)
43
44 We might want to add the filename too.
45 This can be used for the lightweight stack-tracing stuff too
46
47 Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
48
49 2. Generate a binding for every data type declaration T in module M,
50 M.$tcT :: GHC.Types.TyCon
51 M.$tcT = TyCon ...fingerprint info...
52 $trModule
53 "T"
54 We define (in TyCon)
55 type TyConRepName = Name
56 to use for these M.$tcT "tycon rep names".
57
58 3. Record the TyConRepName in T's TyCon, including for promoted
59 data and type constructors, and kinds like * and #.
60
61 The TyConRepName is not an "implicit Id". It's more like a record
62 selector: the TyCon knows its name but you have to go to the
63 interface file to find its type, value, etc
64
65 4. Solve Typeable constraints. This is done by a custom Typeable solver,
66 currently in TcInteract, that use M.$tcT so solve (Typeable T).
67
68 There are many wrinkles:
69
70 * The timing of when we produce this bindings is rather important: they must be
71 defined after the rest of the module has been typechecked since we need to be
72 able to lookup Module and TyCon in the type environment and we may be
73 currently compiling GHC.Types (where they are defined).
74
75 * GHC.Prim doesn't have any associated object code, so we need to put the
76 representations for types defined in this module elsewhere. We chose this
77 place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for
78 injecting the bindings for the GHC.Prim representions when compiling
79 GHC.Types.
80
81 * TyCon.tyConRepModOcc is responsible for determining where to find
82 the representation binding for a given type. This is where we handle
83 the special case for GHC.Prim.
84
85 * To save space and reduce dependencies, we need use quite low-level
86 representations for TyCon and Module. See GHC.Types
87 Note [Runtime representation of modules and tycons]
88
89 -}
90
91 -- | Generate the Typeable bindings for a module. This is the only
92 -- entry-point of this module and is invoked by the typechecker driver in
93 -- 'tcRnSrcDecls'.
94 --
95 -- See Note [Grand plan for Typeable] in TcTypeable.
96 mkTypeableBinds :: TcM TcGblEnv
97 mkTypeableBinds
98 = do { -- Create a binding for $trModule.
99 -- Do this before processing any data type declarations,
100 -- which need tcg_tr_module to be initialised
101 ; tcg_env <- mkModIdBindings
102 -- Now we can generate the TyCon representations...
103 -- First we handle the primitive TyCons if we are compiling GHC.Types
104 ; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
105 -- Then we produce bindings for the user-defined types in this module.
106 ; setGblEnv tcg_env $
107
108 do { let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
109 ; traceTc "mkTypeableBinds" (ppr tycons)
110 ; mkTypeableTyConBinds tycons
111 } }
112 where
113 needs_typeable_binds tc =
114 (not (isFamInstTyCon tc) && isAlgTyCon tc)
115 || isDataFamilyTyCon tc
116 || isClassTyCon tc
117
118
119 {- *********************************************************************
120 * *
121 Building top-level binding for $trModule
122 * *
123 ********************************************************************* -}
124
125 mkModIdBindings :: TcM TcGblEnv
126 mkModIdBindings
127 = do { mod <- getModule
128 ; loc <- getSrcSpanM
129 ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
130 ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
131 ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
132 ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
133
134 ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
135 ; return (tcg_env { tcg_tr_module = Just mod_id }
136 `addTypecheckedBinds` [unitBag mod_bind]) }
137
138 mkModIdRHS :: Module -> TcM (LHsExpr Id)
139 mkModIdRHS mod
140 = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
141 ; trNameLit <- mkTrNameLit
142 ; return $ nlHsApps (dataConWrapId trModuleDataCon)
143 [ trNameLit (unitIdFS (moduleUnitId mod))
144 , trNameLit (moduleNameFS (moduleName mod)) ]
145 }
146
147 {- *********************************************************************
148 * *
149 Building type-representation bindings
150 * *
151 ********************************************************************* -}
152
153 -- | Generate TyCon bindings for a set of type constructors
154 mkTypeableTyConBinds :: [TyCon] -> TcM TcGblEnv
155 mkTypeableTyConBinds tycons
156 = do { gbl_env <- getGblEnv
157 ; mod <- getModule
158 ; let mod_expr = case tcg_tr_module gbl_env of -- Should be set by now
159 Just mod_id -> nlHsVar mod_id
160 Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
161 ; stuff <- collect_stuff mod mod_expr
162 ; let all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
163 -- We need type representations for any associated types
164 tc_binds = map (mk_typeable_binds stuff) all_tycons
165 tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
166
167 ; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv
168 ; return (gbl_env `addTypecheckedBinds` tc_binds) }
169
170 -- | Generate bindings for the type representation of a wired-in TyCon defined
171 -- by the virtual "GHC.Prim" module. This is where we inject the representation
172 -- bindings for primitive types into "GHC.Types"
173 --
174 -- See Note [Grand plan for Typeable] in this module.
175 mkPrimTypeableBinds :: TcM TcGblEnv
176 mkPrimTypeableBinds
177 = do { mod <- getModule
178 ; if mod == gHC_TYPES
179 then do { trModuleTyCon <- tcLookupTyCon trModuleTyConName
180 ; let ghc_prim_module_id =
181 mkExportedVanillaId trGhcPrimModuleName
182 (mkTyConTy trModuleTyCon)
183
184 ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
185 <$> mkModIdRHS gHC_PRIM
186
187 ; stuff <- collect_stuff gHC_PRIM (nlHsVar ghc_prim_module_id)
188 ; let prim_binds :: LHsBinds Id
189 prim_binds = unitBag ghc_prim_module_bind
190 `unionBags` ghcPrimTypeableBinds stuff
191
192 prim_rep_ids = collectHsBindsBinders prim_binds
193 ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
194 ; return (gbl_env `addTypecheckedBinds` [prim_binds])
195 }
196 else getGblEnv
197 }
198 where
199
200 -- | Generate bindings for the type representation of the wired-in TyCons defined
201 -- by the virtual "GHC.Prim" module. This differs from the usual
202 -- @mkTypeableBinds@ path in that here we need to lie to 'mk_typeable_binds'
203 -- about the module we are compiling (since we are currently compiling
204 -- "GHC.Types" yet are producing representations for types in "GHC.Prim").
205 --
206 -- See Note [Grand plan for Typeable] in this module.
207 ghcPrimTypeableBinds :: TypeableStuff -> LHsBinds Id
208 ghcPrimTypeableBinds stuff
209 = unionManyBags (map mkBind all_prim_tys)
210 where
211 all_prim_tys :: [TyCon]
212 all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
213 , tc' <- tc : tyConATs tc ]
214
215 mkBind :: TyCon -> LHsBinds Id
216 mkBind = mk_typeable_binds stuff
217
218 data TypeableStuff
219 = Stuff { dflags :: DynFlags
220 , mod_rep :: LHsExpr Id -- ^ Of type GHC.Types.Module
221 , pkg_str :: String -- ^ Package name
222 , mod_str :: String -- ^ Module name
223 , trTyConTyCon :: TyCon -- ^ of @TyCon@
224 , trTyConDataCon :: DataCon -- ^ of @TyCon@
225 , trNameLit :: FastString -> LHsExpr Id
226 -- ^ To construct @TrName@s
227 }
228
229 -- | Collect various tidbits which we'll need to generate TyCon representations.
230 collect_stuff :: Module -> LHsExpr Id -> TcM TypeableStuff
231 collect_stuff mod mod_rep = do
232 dflags <- getDynFlags
233 let pkg_str = unitIdString (moduleUnitId mod)
234 mod_str = moduleNameString (moduleName mod)
235
236 trTyConTyCon <- tcLookupTyCon trTyConTyConName
237 trTyConDataCon <- tcLookupDataCon trTyConDataConName
238 trNameLit <- mkTrNameLit
239 return Stuff {..}
240
241 -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
242 -- can save the work of repeating lookups when constructing many TyCon
243 -- representations.
244 mkTrNameLit :: TcM (FastString -> LHsExpr Id)
245 mkTrNameLit = do
246 trNameSDataCon <- tcLookupDataCon trNameSDataConName
247 let trNameLit :: FastString -> LHsExpr Id
248 trNameLit fs = nlHsApps (dataConWrapId trNameSDataCon)
249 [nlHsLit (mkHsStringPrimLit fs)]
250 return trNameLit
251
252 -- | Make bindings for the type representations of a 'TyCon' and its
253 -- promoted constructors.
254 mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
255 mk_typeable_binds stuff tycon
256 = mkTyConRepBinds stuff tycon
257 `unionBags`
258 unionManyBags (map (mkTyConRepBinds stuff . promoteDataCon)
259 (tyConDataCons tycon))
260
261 -- | Make typeable bindings for the given 'TyCon'.
262 mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
263 mkTyConRepBinds stuff@(Stuff {..}) tycon
264 = case tyConRepName_maybe tycon of
265 Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
266 where
267 rep_id = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
268 rep_rhs = mkTyConRepRHS stuff tycon
269 _ -> emptyBag
270
271 -- | Produce the right-hand-side of a @TyCon@ representation.
272 mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
273 mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
274 where
275 rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
276 [ nlHsLit (word64 high), nlHsLit (word64 low)
277 , mod_rep
278 , trNameLit (mkFastString tycon_str) ]
279
280 tycon_str = add_tick (occNameString (getOccName tycon))
281 add_tick s | isPromotedDataCon tycon = '\'' : s
282 | otherwise = s
283
284 hashThis :: String
285 hashThis = unwords [pkg_str, mod_str, tycon_str]
286
287 Fingerprint high low = fingerprintString hashThis
288
289 word64 :: Word64 -> HsLit
290 word64
291 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim NoSourceText (toInteger n)
292 | otherwise = \n -> HsWordPrim NoSourceText (toInteger n)