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 ( HsDecl(..), IfaceSig(..) )
13 import TcMonoType ( tcHsType, tcHsTypeKind,
14 -- NB: all the tyars in interface files are kinded,
15 -- so tcHsType will do the Right Thing without
16 -- having to mess about with zonking
19 import TcEnv ( ValueEnv, tcExtendTyVarEnv,
20 tcExtendGlobalValEnv, tcSetValueEnv,
22 explicitLookupValue, badCon, badPrimOp, valueEnvIds
24 import TcType ( TcKind, kindToTcKind )
26 import RnHsSyn ( RenamedHsDecl )
28 import Literal ( Literal(..) )
30 import CoreUtils ( exprType )
32 import CoreLint ( lintUnfolding )
33 import WorkWrap ( mkWrapper )
34 import PrimOp ( PrimOp(..) )
36 import Id ( Id, mkId, mkVanillaId,
39 import MkId ( mkCCallOpId )
41 import DataCon ( dataConSig, dataConArgTys )
42 import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy )
43 import Var ( mkTyVar, tyVarKind )
45 import Name ( Name, NamedThing(..), isLocallyDefined )
46 import Unique ( rationalTyConKey )
47 import TysWiredIn ( integerTy, stringTy )
48 import Demand ( wwLazy )
49 import ErrUtils ( pprBagOfErrors )
50 import Maybes ( maybeToBool, MaybeErr(..) )
52 import Util ( zipWithEqual )
55 Ultimately, type signatures in interfaces will have pragmatic
56 information attached, so it is a good idea to have separate code to
59 As always, we do not have to worry about user-pragmas in interface
63 tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings
64 -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
68 tcInterfaceSigs unf_env decls
69 = listTc [ do_one name ty id_infos src_loc
70 | SigD (IfaceSig name ty id_infos src_loc) <- decls]
72 in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
74 do_one name ty id_infos src_loc
75 = tcAddSrcLoc src_loc $
76 tcAddErrCtxt (ifaceSigCtxt name) $
77 tcHsType ty `thenTc` \ sigma_ty ->
78 tcIdInfo unf_env in_scope_vars name
79 sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
80 returnTc (mkId name sigma_ty id_info)
84 tcIdInfo unf_env in_scope_vars name ty info info_ins
85 = foldlTc tcPrag vanillaIdInfo info_ins
87 tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
88 tcPrag info (HsUpdate upd) = returnTc (info `setUpdateInfo` upd)
89 tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
90 tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
92 tcPrag info (HsUnfold inline_prag expr)
93 = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' ->
95 -- maybe_expr doesn't get looked at if the unfolding
96 -- is never inspected; so the typecheck doesn't even happen
97 unfold_info = case maybe_expr' of
98 Nothing -> noUnfolding
99 Just expr' -> mkTopUnfolding expr'
100 info1 = info `setUnfoldingInfo` unfold_info
101 info2 = info1 `setInlinePragInfo` inline_prag
105 tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
106 = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
108 tcPrag info (HsWorker nm)
109 = tcWorkerInfo unf_env ty info nm
113 tcWorkerInfo unf_env ty info worker_name
114 | not (hasArity arity_info)
115 = pprPanic "Worker with no arity info" (ppr worker_name)
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 explicitLookupValue unf_env worker_name of
122 Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
123 `setWorkerInfo` HasWorker worker_id arity
125 Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
129 -- We are relying here on arity, cpr and strictness info always appearing
130 -- before worker info, fingers crossed ....
131 arity_info = arityInfo info
132 arity = arityLowerBound arity_info
133 cpr_info = cprInfo info
134 (demands, res_bot) = case strictnessInfo info of
135 StrictnessInfo d r -> (d,r)
136 _ -> (take arity (repeat wwLazy),False) -- Noncommittal
139 For unfoldings we try to do the job lazily, so that we never type check
140 an unfolding that isn't going to be looked at.
143 tcPragExpr unf_env name in_scope_vars expr
144 = tcDelay unf_env doc $
145 tcCoreExpr expr `thenTc` \ core_expr' ->
147 -- Check for type consistency in the unfolding
148 tcGetSrcLoc `thenNF_Tc` \ src_loc ->
149 case lintUnfolding src_loc in_scope_vars core_expr' of
150 Nothing -> returnTc core_expr'
151 Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
153 doc = text "unfolding of" <+> ppr name
155 tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
156 tcDelay unf_env doc thing_inside
158 recoverNF_Tc bad_value (
159 tcSetValueEnv unf_env thing_inside `thenTc` \ r ->
163 -- The trace tells what wasn't available, for the benefit of
164 -- compiler hackers who want to improve it!
165 bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
166 returnNF_Tc (pprTrace "Failed:"
167 (hang doc 4 (pprBagOfErrors errs))
172 Variables in unfoldings
173 ~~~~~~~~~~~~~~~~~~~~~~~
174 ****** Inside here we use only the Global environment, even for locally bound variables.
175 ****** Why? Because we know all the types and want to bind them to real Ids.
178 tcVar :: Name -> TcM s Id
180 = tcLookupValueMaybe name `thenNF_Tc` \ maybe_id ->
182 Just id -> returnTc id;
183 Nothing -> failWithTc (noDecl name)
186 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
192 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
194 tcCoreExpr (UfType ty)
195 = tcHsTypeKind ty `thenTc` \ (_, ty') ->
196 -- It might not be of kind type
199 tcCoreExpr (UfVar name)
200 = tcVar name `thenTc` \ id ->
203 tcCoreExpr (UfLit lit)
206 -- The dreaded lit-lits are also similar, except here the type
207 -- is read in explicitly rather than being implicit
208 tcCoreExpr (UfLitLit lit ty)
209 = tcHsType ty `thenTc` \ ty' ->
210 returnTc (Lit (MachLitLit lit ty'))
212 tcCoreExpr (UfCCall cc ty)
213 = tcHsType ty `thenTc` \ ty' ->
214 tcGetUnique `thenNF_Tc` \ u ->
215 returnTc (Var (mkCCallOpId u cc ty'))
217 tcCoreExpr (UfTuple name args)
218 = tcVar name `thenTc` \ con_id ->
219 mapTc tcCoreExpr args `thenTc` \ args' ->
221 -- Put the missing type arguments back in
222 con_args = map (Type . unUsgTy . exprType) args' ++ args'
224 returnTc (mkApps (Var con_id) con_args)
226 tcCoreExpr (UfLam bndr body)
227 = tcCoreLamBndr bndr $ \ bndr' ->
228 tcCoreExpr body `thenTc` \ body' ->
229 returnTc (Lam bndr' body')
231 tcCoreExpr (UfApp fun arg)
232 = tcCoreExpr fun `thenTc` \ fun' ->
233 tcCoreExpr arg `thenTc` \ arg' ->
234 returnTc (App fun' arg')
236 tcCoreExpr (UfCase scrut case_bndr alts)
237 = tcCoreExpr scrut `thenTc` \ scrut' ->
239 scrut_ty = exprType scrut'
240 case_bndr' = mkVanillaId case_bndr scrut_ty
242 tcExtendGlobalValEnv [case_bndr'] $
243 mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
244 returnTc (Case scrut' case_bndr' alts')
246 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
247 = tcCoreExpr rhs `thenTc` \ rhs' ->
248 tcCoreValBndr bndr $ \ bndr' ->
249 tcCoreExpr body `thenTc` \ body' ->
250 returnTc (Let (NonRec bndr' rhs') body')
252 tcCoreExpr (UfLet (UfRec pairs) body)
253 = tcCoreValBndrs bndrs $ \ bndrs' ->
254 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
255 tcCoreExpr body `thenTc` \ body' ->
256 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
258 (bndrs, rhss) = unzip pairs
260 tcCoreExpr (UfNote note expr)
261 = tcCoreExpr expr `thenTc` \ expr' ->
263 UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
264 returnTc (Note (Coerce (unUsgTy to_ty')
265 (unUsgTy (exprType expr'))) expr')
266 UfInlineCall -> returnTc (Note InlineCall expr')
267 UfInlineMe -> returnTc (Note InlineMe expr')
268 UfSCC cc -> returnTc (Note (SCC cc) expr')
270 tcCoreNote (UfSCC cc) = returnTc (SCC cc)
271 tcCoreNote UfInlineCall = returnTc InlineCall
275 tcCoreLamBndr (UfValBinder name ty) thing_inside
276 = tcHsType ty `thenTc` \ ty' ->
278 id = mkVanillaId name ty'
280 tcExtendGlobalValEnv [id] $
283 tcCoreLamBndr (UfTyBinder name kind) thing_inside
285 tyvar = mkTyVar name kind
287 tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
289 tcCoreLamBndrs [] thing_inside = thing_inside []
290 tcCoreLamBndrs (b:bs) thing_inside
291 = tcCoreLamBndr b $ \ b' ->
292 tcCoreLamBndrs bs $ \ bs' ->
293 thing_inside (b':bs')
295 tcCoreValBndr (UfValBinder name ty) thing_inside
296 = tcHsType ty `thenTc` \ ty' ->
298 id = mkVanillaId name ty'
300 tcExtendGlobalValEnv [id] $
303 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
304 = mapTc tcHsType tys `thenTc` \ tys' ->
306 ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
308 tcExtendGlobalValEnv ids $
311 names = [name | UfValBinder name _ <- bndrs]
312 tys = [ty | UfValBinder _ ty <- bndrs]
316 tcCoreAlt scrut_ty (UfDefault, names, rhs)
317 = ASSERT( null names )
318 tcCoreExpr rhs `thenTc` \ rhs' ->
319 returnTc (DEFAULT, [], rhs')
321 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
322 = ASSERT( null names )
323 tcCoreExpr rhs `thenTc` \ rhs' ->
324 returnTc (LitAlt lit, [], rhs')
326 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
327 = ASSERT( null names )
328 tcCoreExpr rhs `thenTc` \ rhs' ->
329 tcHsType ty `thenTc` \ ty' ->
330 returnTc (LitAlt (MachLitLit str ty'), [], rhs')
332 -- A case alternative is made quite a bit more complicated
333 -- by the fact that we omit type annotations because we can
334 -- work them out. True enough, but its not that easy!
335 tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs)
336 = tcVar con_name `thenTc` \ con_id ->
338 con = case isDataConWrapId_maybe con_id of
340 Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
342 (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
344 (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
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_name, names, rhs) $$
353 (ppr main_tyvars <+> ppr ex_tyvars) $$
357 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
359 ASSERT( con `elem` cons && 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')
367 ifaceSigCtxt sig_name
368 = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]