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 ( TcEnv, RecTcEnv, tcExtendTyVarEnv,
15 tcExtendGlobalValEnv, tcSetEnv,
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, mkId, mkVanillaId, isDataConWrapId_maybe )
29 import MkId ( mkCCallOpId )
31 import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
32 import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
33 import TysWiredIn ( tupleCon )
34 import Var ( mkTyVar, tyVarKind )
36 import Demand ( wwLazy )
37 import ErrUtils ( pprBagOfErrors )
39 import Util ( zipWithEqual )
40 import HscTypes ( TyThing(..) )
43 Ultimately, type signatures in interfaces will have pragmatic
44 information attached, so it is a good idea to have separate code to
47 As always, we do not have to worry about user-pragmas in interface
51 tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
52 -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
56 tcInterfaceSigs unf_env decls
57 = listTc [ do_one name ty id_infos src_loc
58 | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
60 in_scope_vars = [] -- I think this will be OK
62 do_one name ty id_infos src_loc
63 = tcAddSrcLoc src_loc $
64 tcAddErrCtxt (ifaceSigCtxt name) $
65 tcIfaceType ty `thenTc` \ sigma_ty ->
66 tcIdInfo unf_env in_scope_vars name
67 sigma_ty id_infos `thenTc` \ id_info ->
68 returnTc (mkId name sigma_ty id_info)
72 tcIdInfo unf_env in_scope_vars name ty info_ins
73 = foldlTc tcPrag constantIdInfo info_ins
75 tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
76 tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
77 tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
79 tcPrag info (HsUnfold inline_prag expr)
80 = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' ->
82 -- maybe_expr doesn't get looked at if the unfolding
83 -- is never inspected; so the typecheck doesn't even happen
84 unfold_info = case maybe_expr' of
85 Nothing -> noUnfolding
86 Just expr' -> mkTopUnfolding expr'
87 info1 = info `setUnfoldingInfo` unfold_info
88 info2 = info1 `setInlinePragInfo` inline_prag
92 tcPrag info (HsStrictness strict_info)
93 = returnTc (info `setStrictnessInfo` strict_info)
95 tcPrag info (HsWorker nm)
96 = tcWorkerInfo unf_env ty info nm
100 tcWorkerInfo unf_env ty info worker_name
101 | not (hasArity arity_info)
102 = pprPanic "Worker with no arity info" (ppr worker_name)
105 = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
107 -- Watch out! We can't pull on unf_env too eagerly!
108 info' = case tcLookupRecId_maybe unf_env worker_name of
109 Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
110 `setWorkerInfo` HasWorker worker_id arity
112 Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
116 -- We are relying here on arity, cpr and strictness info always appearing
117 -- before worker info, fingers crossed ....
118 arity_info = arityInfo info
119 arity = arityLowerBound arity_info
120 cpr_info = cprInfo info
121 (demands, res_bot) = case strictnessInfo info of
122 StrictnessInfo d r -> (d,r)
123 _ -> (take arity (repeat wwLazy),False) -- Noncommittal
126 For unfoldings we try to do the job lazily, so that we never type check
127 an unfolding that isn't going to be looked at.
130 tcPragExpr unf_env name in_scope_vars expr
131 = tcDelay unf_env doc $
132 tcCoreExpr expr `thenTc` \ core_expr' ->
134 -- Check for type consistency in the unfolding
135 tcGetSrcLoc `thenNF_Tc` \ src_loc ->
136 getDOptsTc `thenTc` \ dflags ->
137 case lintUnfolding dflags src_loc in_scope_vars core_expr' of
138 (Nothing,_) -> returnTc core_expr' -- ignore warnings
139 (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
141 doc = text "unfolding of" <+> ppr name
143 tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
144 tcDelay unf_env doc thing_inside
146 recoverNF_Tc bad_value (
147 tcSetEnv unf_env thing_inside `thenTc` \ r ->
151 -- The trace tells what wasn't available, for the benefit of
152 -- compiler hackers who want to improve it!
153 bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
154 returnNF_Tc (pprTrace "Failed:"
155 (hang doc 4 (pprBagOfErrors errs))
160 Variables in unfoldings
161 ~~~~~~~~~~~~~~~~~~~~~~~
162 ****** Inside here we use only the Global environment, even for locally bound variables.
163 ****** Why? Because we know all the types and want to bind them to real Ids.
166 tcVar :: Name -> TcM Id
168 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
170 Just (AnId id) -> returnTc id;
171 Nothing -> failWithTc (noDecl name)
174 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
180 tcCoreExpr :: UfExpr Name -> TcM CoreExpr
182 tcCoreExpr (UfType ty)
183 = tcIfaceType ty `thenTc` \ ty' ->
184 -- It might not be of kind type
187 tcCoreExpr (UfVar name)
188 = tcVar name `thenTc` \ id ->
191 tcCoreExpr (UfLit lit)
194 -- The dreaded lit-lits are also similar, except here the type
195 -- is read in explicitly rather than being implicit
196 tcCoreExpr (UfLitLit lit ty)
197 = tcIfaceType ty `thenTc` \ ty' ->
198 returnTc (Lit (MachLitLit lit ty'))
200 tcCoreExpr (UfCCall cc ty)
201 = tcIfaceType ty `thenTc` \ ty' ->
202 tcGetUnique `thenNF_Tc` \ u ->
203 returnTc (Var (mkCCallOpId u cc ty'))
205 tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
206 = mapTc tcCoreExpr args `thenTc` \ args' ->
208 -- Put the missing type arguments back in
209 con_args = map (Type . exprType) args' ++ args'
211 returnTc (mkApps (Var con_id) con_args)
213 con_id = dataConId (tupleCon boxity arity)
216 tcCoreExpr (UfLam bndr body)
217 = tcCoreLamBndr bndr $ \ bndr' ->
218 tcCoreExpr body `thenTc` \ body' ->
219 returnTc (Lam bndr' body')
221 tcCoreExpr (UfApp fun arg)
222 = tcCoreExpr fun `thenTc` \ fun' ->
223 tcCoreExpr arg `thenTc` \ arg' ->
224 returnTc (App fun' arg')
226 tcCoreExpr (UfCase scrut case_bndr alts)
227 = tcCoreExpr scrut `thenTc` \ scrut' ->
229 scrut_ty = exprType scrut'
230 case_bndr' = mkVanillaId case_bndr scrut_ty
232 tcExtendGlobalValEnv [case_bndr'] $
233 mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
234 returnTc (Case scrut' case_bndr' alts')
236 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
237 = tcCoreExpr rhs `thenTc` \ rhs' ->
238 tcCoreValBndr bndr $ \ bndr' ->
239 tcCoreExpr body `thenTc` \ body' ->
240 returnTc (Let (NonRec bndr' rhs') body')
242 tcCoreExpr (UfLet (UfRec pairs) body)
243 = tcCoreValBndrs bndrs $ \ bndrs' ->
244 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
245 tcCoreExpr body `thenTc` \ body' ->
246 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
248 (bndrs, rhss) = unzip pairs
250 tcCoreExpr (UfNote note expr)
251 = tcCoreExpr expr `thenTc` \ expr' ->
253 UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' ->
254 returnTc (Note (Coerce to_ty'
255 (exprType expr')) expr')
256 UfInlineCall -> returnTc (Note InlineCall expr')
257 UfInlineMe -> returnTc (Note InlineMe expr')
258 UfSCC cc -> returnTc (Note (SCC cc) expr')
262 tcCoreLamBndr (UfValBinder name ty) thing_inside
263 = tcIfaceType ty `thenTc` \ ty' ->
265 id = mkVanillaId name ty'
267 tcExtendGlobalValEnv [id] $
270 tcCoreLamBndr (UfTyBinder name kind) thing_inside
272 tyvar = mkTyVar name kind
274 tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
276 tcCoreLamBndrs [] thing_inside = thing_inside []
277 tcCoreLamBndrs (b:bs) thing_inside
278 = tcCoreLamBndr b $ \ b' ->
279 tcCoreLamBndrs bs $ \ bs' ->
280 thing_inside (b':bs')
282 tcCoreValBndr (UfValBinder name ty) thing_inside
283 = tcIfaceType ty `thenTc` \ ty' ->
285 id = mkVanillaId name ty'
287 tcExtendGlobalValEnv [id] $
290 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
291 = mapTc tcIfaceType tys `thenTc` \ tys' ->
293 ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
295 tcExtendGlobalValEnv ids $
298 names = [name | UfValBinder name _ <- bndrs]
299 tys = [ty | UfValBinder _ ty <- bndrs]
303 tcCoreAlt scrut_ty (UfDefault, names, rhs)
304 = ASSERT( null names )
305 tcCoreExpr rhs `thenTc` \ rhs' ->
306 returnTc (DEFAULT, [], rhs')
308 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
309 = ASSERT( null names )
310 tcCoreExpr rhs `thenTc` \ rhs' ->
311 returnTc (LitAlt lit, [], rhs')
313 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
314 = ASSERT( null names )
315 tcCoreExpr rhs `thenTc` \ rhs' ->
316 tcIfaceType ty `thenTc` \ ty' ->
317 returnTc (LitAlt (MachLitLit str ty'), [], rhs')
319 -- A case alternative is made quite a bit more complicated
320 -- by the fact that we omit type annotations because we can
321 -- work them out. True enough, but its not that easy!
322 tcCoreAlt scrut_ty alt@(con, names, rhs)
323 = tcConAlt con `thenTc` \ con ->
325 (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
327 (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
329 Nothing -> pprPanic "tcCoreAlt" (ppr alt)
330 ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
331 ex_tys' = mkTyVarTys ex_tyvars'
332 arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
333 id_names = drop (length ex_tyvars) names
336 | length id_names /= length arg_tys
337 = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
338 (ppr main_tyvars <+> ppr ex_tyvars) $$
342 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
344 ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
345 tcExtendTyVarEnv ex_tyvars' $
346 tcExtendGlobalValEnv arg_ids $
347 tcCoreExpr rhs `thenTc` \ rhs' ->
348 returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
351 tcConAlt :: UfConAlt Name -> TcM DataCon
352 tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
353 = returnTc (tupleCon boxity arity)
355 tcConAlt (UfDataAlt con_name)
356 = tcVar con_name `thenTc` \ con_id ->
357 returnTc (case isDataConWrapId_maybe con_id of
359 Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
363 ifaceSigCtxt sig_name
364 = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]