2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
7 module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
9 #include "HsVersions.h"
11 import HsSyn ( TyClDecl(..), HsTupCon(..) )
13 import TcMonoType ( tcIfaceType )
14 import TcEnv ( RecTcEnv, tcExtendTyVarEnv,
15 tcExtendGlobalValEnv, tcSetEnv, tcEnvIds,
16 tcLookupGlobal_maybe, tcLookupRecId_maybe
19 import RnHsSyn ( RenamedTyClDecl )
21 import Literal ( Literal(..) )
23 import CoreUtils ( exprType )
25 import CoreLint ( lintUnfolding )
26 import WorkWrap ( mkWrapper )
28 import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
29 import Module ( Module )
30 import MkId ( mkFCallId )
32 import TyCon ( tyConDataCons )
33 import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
34 import Type ( mkTyVarTys, splitTyConApp )
35 import TysWiredIn ( tupleCon )
36 import Var ( mkTyVar, tyVarKind )
37 import Name ( Name, nameIsLocalOrFrom )
38 import Demand ( wwLazy )
39 import ErrUtils ( pprBagOfErrors )
41 import Util ( zipWithEqual )
42 import HscTypes ( TyThing(..) )
45 Ultimately, type signatures in interfaces will have pragmatic
46 information attached, so it is a good idea to have separate code to
49 As always, we do not have to worry about user-pragmas in interface
53 tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
54 -> Module -- This module
55 -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
59 tcInterfaceSigs unf_env mod decls
60 = listTc [ do_one name ty id_infos src_loc
61 | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
63 in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
64 -- Oops: using isLocalId instead can give a black hole
65 -- because it looks at the idinfo
67 -- When we have hi-boot files, an unfolding might refer to
68 -- something defined in this module, so we must build a
69 -- suitable in-scope set. This thunk will only be poked
70 -- if -dcore-lint is on.
72 do_one name ty id_infos src_loc
73 = tcAddSrcLoc src_loc $
74 tcAddErrCtxt (ifaceSigCtxt name) $
75 tcIfaceType ty `thenTc` \ sigma_ty ->
76 tcIdInfo unf_env in_scope_vars name
77 sigma_ty id_infos `thenTc` \ id_info ->
78 returnTc (mkVanillaGlobal name sigma_ty id_info)
82 tcIdInfo unf_env in_scope_vars name ty info_ins
83 = foldlTc tcPrag init_info info_ins
85 -- set the CgInfo to something sensible but uninformative before
86 -- we start, because the default CgInfo is a panic.
87 init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
89 tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
90 tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
92 tcPrag info (HsArity arity) =
93 returnTc (info `setArityInfo` (ArityExactly arity)
96 tcPrag info (HsUnfold inline_prag expr)
97 = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' ->
99 -- maybe_expr doesn't get looked at if the unfolding
100 -- is never inspected; so the typecheck doesn't even happen
101 unfold_info = case maybe_expr' of
102 Nothing -> noUnfolding
103 Just expr' -> mkTopUnfolding expr'
104 info1 = info `setUnfoldingInfo` unfold_info
105 info2 = info1 `setInlinePragInfo` inline_prag
109 tcPrag info (HsStrictness strict_info)
110 = returnTc (info `setStrictnessInfo` strict_info)
112 tcPrag info (HsWorker nm arity)
113 = tcWorkerInfo unf_env ty info nm arity
117 tcWorkerInfo unf_env ty info worker_name arity
118 = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
120 -- Watch out! We can't pull on unf_env too eagerly!
121 info' = case tcLookupRecId_maybe unf_env worker_name of
123 info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
124 `setWorkerInfo` HasWorker worker_id arity
126 Nothing -> pprTrace "tcWorkerInfo failed:"
127 (ppr worker_name) info
131 -- We are relying here on cpr and strictness info always appearing
132 -- before worker info, fingers crossed ....
133 cpr_info = cprInfo info
136 = case strictnessInfo info of
137 StrictnessInfo d r -> (d,r)
138 _ -> (take arity (repeat wwLazy),False)
142 For unfoldings we try to do the job lazily, so that we never type check
143 an unfolding that isn't going to be looked at.
146 tcPragExpr unf_env name in_scope_vars expr
147 = tcDelay unf_env doc $
148 tcCoreExpr expr `thenTc` \ core_expr' ->
150 -- Check for type consistency in the unfolding
151 tcGetSrcLoc `thenNF_Tc` \ src_loc ->
152 getDOptsTc `thenTc` \ dflags ->
153 case lintUnfolding dflags src_loc in_scope_vars core_expr' of
154 (Nothing,_) -> returnTc core_expr' -- ignore warnings
155 (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
157 doc = text "unfolding of" <+> ppr name
159 tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
160 tcDelay unf_env doc thing_inside
162 recoverNF_Tc bad_value (
163 tcSetEnv unf_env thing_inside `thenTc` \ r ->
167 -- The trace tells what wasn't available, for the benefit of
168 -- compiler hackers who want to improve it!
169 bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
170 returnNF_Tc (pprTrace "Failed:"
171 (hang doc 4 (pprBagOfErrors errs))
176 Variables in unfoldings
177 ~~~~~~~~~~~~~~~~~~~~~~~
178 ****** Inside here we use only the Global environment, even for locally bound variables.
179 ****** Why? Because we know all the types and want to bind them to real Ids.
182 tcVar :: Name -> TcM Id
184 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
186 Just (AnId id) -> returnTc id ;
187 Nothing -> failWithTc (noDecl name)
190 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
196 tcCoreExpr :: UfExpr Name -> TcM CoreExpr
198 tcCoreExpr (UfType ty)
199 = tcIfaceType ty `thenTc` \ ty' ->
200 -- It might not be of kind type
203 tcCoreExpr (UfVar name)
204 = tcVar name `thenTc` \ id ->
207 tcCoreExpr (UfLit lit)
210 -- The dreaded lit-lits are also similar, except here the type
211 -- is read in explicitly rather than being implicit
212 tcCoreExpr (UfLitLit lit ty)
213 = tcIfaceType ty `thenTc` \ ty' ->
214 returnTc (Lit (MachLitLit lit ty'))
216 tcCoreExpr (UfFCall cc ty)
217 = tcIfaceType ty `thenTc` \ ty' ->
218 tcGetUnique `thenNF_Tc` \ u ->
219 returnTc (Var (mkFCallId u cc ty'))
221 tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
222 = mapTc tcCoreExpr args `thenTc` \ args' ->
224 -- Put the missing type arguments back in
225 con_args = map (Type . exprType) args' ++ args'
227 returnTc (mkApps (Var con_id) con_args)
229 con_id = dataConId (tupleCon boxity arity)
232 tcCoreExpr (UfLam bndr body)
233 = tcCoreLamBndr bndr $ \ bndr' ->
234 tcCoreExpr body `thenTc` \ body' ->
235 returnTc (Lam bndr' body')
237 tcCoreExpr (UfApp fun arg)
238 = tcCoreExpr fun `thenTc` \ fun' ->
239 tcCoreExpr arg `thenTc` \ arg' ->
240 returnTc (App fun' arg')
242 tcCoreExpr (UfCase scrut case_bndr alts)
243 = tcCoreExpr scrut `thenTc` \ scrut' ->
245 scrut_ty = exprType scrut'
246 case_bndr' = mkLocalId case_bndr scrut_ty
248 tcExtendGlobalValEnv [case_bndr'] $
249 mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
250 returnTc (Case scrut' case_bndr' alts')
252 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
253 = tcCoreExpr rhs `thenTc` \ rhs' ->
254 tcCoreValBndr bndr $ \ bndr' ->
255 tcCoreExpr body `thenTc` \ body' ->
256 returnTc (Let (NonRec bndr' rhs') body')
258 tcCoreExpr (UfLet (UfRec pairs) body)
259 = tcCoreValBndrs bndrs $ \ bndrs' ->
260 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
261 tcCoreExpr body `thenTc` \ body' ->
262 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
264 (bndrs, rhss) = unzip pairs
266 tcCoreExpr (UfNote note expr)
267 = tcCoreExpr expr `thenTc` \ expr' ->
269 UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' ->
270 returnTc (Note (Coerce to_ty'
271 (exprType expr')) expr')
272 UfInlineCall -> returnTc (Note InlineCall expr')
273 UfInlineMe -> returnTc (Note InlineMe expr')
274 UfSCC cc -> returnTc (Note (SCC cc) expr')
278 tcCoreLamBndr (UfValBinder name ty) thing_inside
279 = tcIfaceType ty `thenTc` \ ty' ->
281 id = mkLocalId name ty'
283 tcExtendGlobalValEnv [id] $
286 tcCoreLamBndr (UfTyBinder name kind) thing_inside
288 tyvar = mkTyVar name kind
290 tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
292 tcCoreLamBndrs [] thing_inside = thing_inside []
293 tcCoreLamBndrs (b:bs) thing_inside
294 = tcCoreLamBndr b $ \ b' ->
295 tcCoreLamBndrs bs $ \ bs' ->
296 thing_inside (b':bs')
298 tcCoreValBndr (UfValBinder name ty) thing_inside
299 = tcIfaceType ty `thenTc` \ ty' ->
301 id = mkLocalId name ty'
303 tcExtendGlobalValEnv [id] $
306 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
307 = mapTc tcIfaceType tys `thenTc` \ tys' ->
309 ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
311 tcExtendGlobalValEnv ids $
314 names = [name | UfValBinder name _ <- bndrs]
315 tys = [ty | UfValBinder _ ty <- bndrs]
319 tcCoreAlt scrut_ty (UfDefault, names, rhs)
320 = ASSERT( null names )
321 tcCoreExpr rhs `thenTc` \ rhs' ->
322 returnTc (DEFAULT, [], rhs')
324 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
325 = ASSERT( null names )
326 tcCoreExpr rhs `thenTc` \ rhs' ->
327 returnTc (LitAlt lit, [], rhs')
329 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
330 = ASSERT( null names )
331 tcCoreExpr rhs `thenTc` \ rhs' ->
332 tcIfaceType ty `thenTc` \ ty' ->
333 returnTc (LitAlt (MachLitLit str ty'), [], rhs')
335 -- A case alternative is made quite a bit more complicated
336 -- by the fact that we omit type annotations because we can
337 -- work them out. True enough, but its not that easy!
338 tcCoreAlt scrut_ty alt@(con, names, rhs)
339 = tcConAlt con `thenTc` \ con ->
341 (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
343 (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp
344 -- We are looking at Core here
345 ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
346 ex_tys' = mkTyVarTys ex_tyvars'
347 arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
348 id_names = drop (length ex_tyvars) names
351 | length id_names /= length arg_tys
352 = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
353 (ppr main_tyvars <+> ppr ex_tyvars) $$
357 = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
359 ASSERT( con `elem` tyConDataCons tycon && length inst_tys == length main_tyvars )
360 tcExtendTyVarEnv ex_tyvars' $
361 tcExtendGlobalValEnv arg_ids $
362 tcCoreExpr rhs `thenTc` \ rhs' ->
363 returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
366 tcConAlt :: UfConAlt Name -> TcM DataCon
367 tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
368 = returnTc (tupleCon boxity arity)
370 tcConAlt (UfDataAlt con_name)
371 = tcVar con_name `thenTc` \ con_id ->
372 returnTc (case isDataConWrapId_maybe con_id of
374 Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
378 ifaceSigCtxt sig_name
379 = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]