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,
21 tcLookupTyConByKey, tcLookupValueMaybe,
22 explicitLookupValue, badCon, badPrimOp
24 import TcType ( TcKind, kindToTcKind )
26 import RnHsSyn ( RenamedHsDecl )
28 import CallConv ( cCallConv )
29 import Const ( Con(..), Literal(..) )
31 import CoreUtils ( coreExprType )
33 import CoreLint ( lintUnfolding )
34 import WwLib ( mkWrapper )
35 import PrimOp ( PrimOp(..) )
37 import Id ( Id, mkId, mkVanillaId,
38 isPrimitiveId_maybe, isDataConId_maybe
41 import DataCon ( dataConSig, dataConArgTys )
42 import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
43 import Var ( IdOrTyVar, mkTyVar, tyVarKind )
45 import Name ( Name, NamedThing(..) )
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 (SigD (IfaceSig name ty id_infos src_loc) : rest)
69 = tcAddSrcLoc src_loc (
70 tcAddErrCtxt (ifaceSigCtxt name) (
71 tcHsType ty `thenTc` \ sigma_ty ->
72 tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
73 returnTc (mkId name sigma_ty id_info)
74 )) `thenTc` \ sig_id ->
75 tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
76 returnTc (sig_id : sig_ids)
78 tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
80 tcInterfaceSigs unf_env [] = returnTc []
84 tcIdInfo unf_env 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 cpr_info) = returnTc (info `setCprInfo` cpr_info)
92 tcPrag info (HsUnfold inline_prag maybe_expr)
94 Just expr -> tcPragExpr unf_env name [] expr
95 Nothing -> returnNF_Tc Nothing
96 ) `thenNF_Tc` \ maybe_expr' ->
98 -- maybe_expr doesn't get looked at if the unfolding
99 -- is never inspected; so the typecheck doesn't even happen
100 unfold_info = case maybe_expr' of
101 Nothing -> noUnfolding
102 Just expr' -> mkUnfolding expr'
103 info1 = info `setUnfoldingInfo` unfold_info
104 info2 = info1 `setInlinePragInfo` inline_prag
108 tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
109 = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
111 tcPrag info (HsWorker nm)
112 = tcWorkerInfo unf_env ty info nm
116 tcWorkerInfo unf_env ty info worker_name
117 | not (hasArity arity_info)
118 = pprPanic "Worker with no arity info" (ppr worker_name)
121 = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn ->
123 -- Watch out! We can't pull on unf_env too eagerly!
124 info' = case explicitLookupValue unf_env worker_name of
125 Just worker_id -> info `setUnfoldingInfo` mkUnfolding (wrap_fn worker_id)
126 `setWorkerInfo` Just worker_id
128 Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
132 -- We are relying here on arity, cpr and strictness info always appearing
133 -- before worker info, fingers crossed ....
134 arity_info = arityInfo info
135 arity = arityLowerBound arity_info
136 cpr_info = cprInfo info
137 demands = case strictnessInfo info of
138 StrictnessInfo d _ -> d
139 _ -> repeat wwLazy -- Noncommittal
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 case lintUnfolding src_loc in_scope_vars core_expr' of
153 Nothing -> returnTc core_expr'
154 Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
156 doc = text "unfolding of" <+> ppr name
158 tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
159 tcDelay unf_env doc thing_inside
161 recoverNF_Tc bad_value (
162 tcSetValueEnv unf_env thing_inside `thenTc` \ r ->
166 -- The trace tells what wasn't available, for the benefit of
167 -- compiler hackers who want to improve it!
168 bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
169 returnNF_Tc (pprTrace "Failed:"
170 (hang doc 4 (pprBagOfErrors errs))
175 Variables in unfoldings
176 ~~~~~~~~~~~~~~~~~~~~~~~
177 ****** Inside here we use only the Global environment, even for locally bound variables.
178 ****** Why? Because we know all the types and want to bind them to real Ids.
181 tcVar :: Name -> TcM s Id
183 = tcLookupValueMaybe name `thenNF_Tc` \ maybe_id ->
185 Just id -> returnTc id;
186 Nothing -> failWithTc (noDecl name)
189 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
195 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
197 tcCoreExpr (UfType ty)
198 = tcHsTypeKind ty `thenTc` \ (_, ty') ->
199 -- It might not be of kind type
202 tcCoreExpr (UfVar name)
203 = tcVar name `thenTc` \ id ->
206 tcCoreExpr (UfCon con args)
207 = tcUfCon con `thenTc` \ con' ->
208 mapTc tcCoreExpr args `thenTc` \ args' ->
209 returnTc (Con con' args')
211 tcCoreExpr (UfTuple name args)
212 = tcUfDataCon name `thenTc` \ con ->
213 mapTc tcCoreExpr args `thenTc` \ args' ->
215 -- Put the missing type arguments back in
216 con_args = map (Type . coreExprType) args' ++ args'
218 returnTc (Con con con_args)
220 tcCoreExpr (UfLam bndr body)
221 = tcCoreLamBndr bndr $ \ bndr' ->
222 tcCoreExpr body `thenTc` \ body' ->
223 returnTc (Lam bndr' body')
225 tcCoreExpr (UfApp fun arg)
226 = tcCoreExpr fun `thenTc` \ fun' ->
227 tcCoreExpr arg `thenTc` \ arg' ->
228 returnTc (App fun' arg')
230 tcCoreExpr (UfCase scrut case_bndr alts)
231 = tcCoreExpr scrut `thenTc` \ scrut' ->
233 scrut_ty = coreExprType scrut'
234 case_bndr' = mkVanillaId case_bndr scrut_ty
236 tcExtendGlobalValEnv [case_bndr'] $
237 mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
238 returnTc (Case scrut' case_bndr' alts')
240 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
241 = tcCoreExpr rhs `thenTc` \ rhs' ->
242 tcCoreValBndr bndr $ \ bndr' ->
243 tcCoreExpr body `thenTc` \ body' ->
244 returnTc (Let (NonRec bndr' rhs') body')
246 tcCoreExpr (UfLet (UfRec pairs) body)
247 = tcCoreValBndrs bndrs $ \ bndrs' ->
248 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
249 tcCoreExpr body `thenTc` \ body' ->
250 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
252 (bndrs, rhss) = unzip pairs
254 tcCoreExpr (UfNote note expr)
255 = tcCoreExpr expr `thenTc` \ expr' ->
257 UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
258 returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
259 UfInlineCall -> returnTc (Note InlineCall expr')
260 UfInlineMe -> returnTc (Note InlineMe expr')
261 UfSCC cc -> returnTc (Note (SCC cc) expr')
263 tcCoreNote (UfSCC cc) = returnTc (SCC cc)
264 tcCoreNote UfInlineCall = returnTc InlineCall
267 -- rationalTy isn't built in so, we have to construct it
268 -- (the "ty" part of the incoming literal is simply bottom)
269 tcUfCon (UfLitCon (NoRepRational lit _))
270 = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
272 rational_ty = mkSynTy rational_tycon []
274 returnTc (Literal (NoRepRational lit rational_ty))
276 -- Similarly for integers and strings, except that they are wired in
277 tcUfCon (UfLitCon (NoRepInteger lit _))
278 = returnTc (Literal (NoRepInteger lit integerTy))
279 tcUfCon (UfLitCon (NoRepStr lit _))
280 = returnTc (Literal (NoRepStr lit stringTy))
282 tcUfCon (UfLitCon other_lit)
283 = returnTc (Literal other_lit)
285 -- The dreaded lit-lits are also similar, except here the type
286 -- is read in explicitly rather than being implicit
287 tcUfCon (UfLitLitCon lit ty)
288 = tcHsType ty `thenTc` \ ty' ->
289 returnTc (Literal (MachLitLit lit ty'))
291 tcUfCon (UfDataCon name) = tcUfDataCon name
293 tcUfCon (UfPrimOp name)
294 = tcVar name `thenTc` \ op_id ->
295 case isPrimitiveId_maybe op_id of
296 Just op -> returnTc (PrimOp op)
297 Nothing -> failWithTc (badPrimOp name)
299 tcUfCon (UfCCallOp str is_dyn casm gc)
302 tcGetUnique `thenNF_Tc` \ u ->
303 returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
304 False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
307 = tcVar name `thenTc` \ con_id ->
308 case isDataConId_maybe con_id of
309 Just con -> returnTc (DataCon con)
310 Nothing -> failWithTc (badCon name)
314 tcCoreLamBndr (UfValBinder name ty) thing_inside
315 = tcHsType ty `thenTc` \ ty' ->
317 id = mkVanillaId name ty'
319 tcExtendGlobalValEnv [id] $
322 tcCoreLamBndr (UfTyBinder name kind) thing_inside
324 tyvar = mkTyVar name kind
326 tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
328 tcCoreLamBndrs [] thing_inside = thing_inside []
329 tcCoreLamBndrs (b:bs) thing_inside
330 = tcCoreLamBndr b $ \ b' ->
331 tcCoreLamBndrs bs $ \ bs' ->
332 thing_inside (b':bs')
334 tcCoreValBndr (UfValBinder name ty) thing_inside
335 = tcHsType ty `thenTc` \ ty' ->
337 id = mkVanillaId name ty'
339 tcExtendGlobalValEnv [id] $
342 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
343 = mapTc tcHsType tys `thenTc` \ tys' ->
345 ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
347 tcExtendGlobalValEnv ids $
350 names = [name | UfValBinder name _ <- bndrs]
351 tys = [ty | UfValBinder _ ty <- bndrs]
355 tcCoreAlt scrut_ty (UfDefault, names, rhs)
356 = ASSERT( null names )
357 tcCoreExpr rhs `thenTc` \ rhs' ->
358 returnTc (DEFAULT, [], rhs')
360 tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
361 = ASSERT( null names )
362 tcCoreExpr rhs `thenTc` \ rhs' ->
363 returnTc (Literal lit, [], rhs')
365 tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
366 = ASSERT( null names )
367 tcCoreExpr rhs `thenTc` \ rhs' ->
368 tcHsType ty `thenTc` \ ty' ->
369 returnTc (Literal (MachLitLit str ty'), [], rhs')
371 -- A case alternative is made quite a bit more complicated
372 -- by the fact that we omit type annotations because we can
373 -- work them out. True enough, but its not that easy!
374 tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
375 = tcVar con_name `thenTc` \ con_id ->
377 con = case isDataConId_maybe con_id of
379 Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
381 (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
383 (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
384 ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
385 ex_tys' = mkTyVarTys ex_tyvars'
386 arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
387 id_names = drop (length ex_tyvars) names
390 | length id_names /= length arg_tys
391 = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
392 (ppr main_tyvars <+> ppr ex_tyvars) $$
396 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
398 ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
399 tcExtendTyVarEnv ex_tyvars' $
400 tcExtendGlobalValEnv arg_ids $
401 tcCoreExpr rhs `thenTc` \ rhs' ->
402 returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
406 ifaceSigCtxt sig_name
407 = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]