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 ( mkCCallOpId )
32 import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
33 import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
34 import TysWiredIn ( tupleCon )
35 import Var ( mkTyVar, tyVarKind )
36 import Name ( Name, nameIsLocalOrFrom )
37 import Demand ( wwLazy )
38 import ErrUtils ( pprBagOfErrors )
40 import Util ( zipWithEqual )
41 import HscTypes ( TyThing(..) )
44 Ultimately, type signatures in interfaces will have pragmatic
45 information attached, so it is a good idea to have separate code to
48 As always, we do not have to worry about user-pragmas in interface
52 tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
53 -> Module -- This module
54 -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
58 tcInterfaceSigs unf_env mod decls
59 = listTc [ do_one name ty id_infos src_loc
60 | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
62 in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
63 -- Oops: using isLocalId instead can give a black hole
64 -- because it looks at the idinfo
66 -- When we have hi-boot files, an unfolding might refer to
67 -- something defined in this module, so we must build a
68 -- suitable in-scope set. This thunk will only be poked
69 -- if -dcore-lint is on.
71 do_one name ty id_infos src_loc
72 = tcAddSrcLoc src_loc $
73 tcAddErrCtxt (ifaceSigCtxt name) $
74 tcIfaceType ty `thenTc` \ sigma_ty ->
75 tcIdInfo unf_env in_scope_vars name
76 sigma_ty id_infos `thenTc` \ id_info ->
77 returnTc (mkVanillaGlobal name sigma_ty id_info)
81 tcIdInfo unf_env in_scope_vars name ty info_ins
82 = foldlTc tcPrag init_info info_ins
84 -- set the CgInfo to something sensible but uninformative before
85 -- we start, because the default CgInfo is a panic.
86 init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
88 tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
89 tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
91 tcPrag info (HsArity arity) =
92 returnTc (info `setArityInfo` (ArityExactly arity)
95 tcPrag info (HsUnfold inline_prag expr)
96 = tcPragExpr unf_env name in_scope_vars expr `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' -> mkTopUnfolding expr'
103 info1 = info `setUnfoldingInfo` unfold_info
104 info2 = info1 `setInlinePragInfo` inline_prag
108 tcPrag info (HsStrictness strict_info)
109 = returnTc (info `setStrictnessInfo` strict_info)
111 tcPrag info (HsWorker nm arity)
112 = tcWorkerInfo unf_env ty info nm arity
116 tcWorkerInfo unf_env ty info worker_name arity
117 = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
119 -- Watch out! We can't pull on unf_env too eagerly!
120 info' = case tcLookupRecId_maybe unf_env worker_name of
122 info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
123 `setWorkerInfo` HasWorker worker_id arity
125 Nothing -> pprTrace "tcWorkerInfo failed:"
126 (ppr worker_name) info
130 -- We are relying here on cpr and strictness info always appearing
131 -- before worker info, fingers crossed ....
132 cpr_info = cprInfo info
135 = case strictnessInfo info of
136 StrictnessInfo d r -> (d,r)
137 _ -> (take arity (repeat wwLazy),False)
141 For unfoldings we try to do the job lazily, so that we never type check
142 an unfolding that isn't going to be looked at.
145 tcPragExpr unf_env name in_scope_vars expr
146 = tcDelay unf_env doc $
147 tcCoreExpr expr `thenTc` \ core_expr' ->
149 -- Check for type consistency in the unfolding
150 tcGetSrcLoc `thenNF_Tc` \ src_loc ->
151 getDOptsTc `thenTc` \ dflags ->
152 case lintUnfolding dflags src_loc in_scope_vars core_expr' of
153 (Nothing,_) -> returnTc core_expr' -- ignore warnings
154 (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
156 doc = text "unfolding of" <+> ppr name
158 tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
159 tcDelay unf_env doc thing_inside
161 recoverNF_Tc bad_value (
162 tcSetEnv 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 Id
183 = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
185 Just (AnId 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 CoreExpr
197 tcCoreExpr (UfType ty)
198 = tcIfaceType ty `thenTc` \ ty' ->
199 -- It might not be of kind type
202 tcCoreExpr (UfVar name)
203 = tcVar name `thenTc` \ id ->
206 tcCoreExpr (UfLit lit)
209 -- The dreaded lit-lits are also similar, except here the type
210 -- is read in explicitly rather than being implicit
211 tcCoreExpr (UfLitLit lit ty)
212 = tcIfaceType ty `thenTc` \ ty' ->
213 returnTc (Lit (MachLitLit lit ty'))
215 tcCoreExpr (UfCCall cc ty)
216 = tcIfaceType ty `thenTc` \ ty' ->
217 tcGetUnique `thenNF_Tc` \ u ->
218 returnTc (Var (mkCCallOpId u cc ty'))
220 tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
221 = mapTc tcCoreExpr args `thenTc` \ args' ->
223 -- Put the missing type arguments back in
224 con_args = map (Type . exprType) args' ++ args'
226 returnTc (mkApps (Var con_id) con_args)
228 con_id = dataConId (tupleCon boxity arity)
231 tcCoreExpr (UfLam bndr body)
232 = tcCoreLamBndr bndr $ \ bndr' ->
233 tcCoreExpr body `thenTc` \ body' ->
234 returnTc (Lam bndr' body')
236 tcCoreExpr (UfApp fun arg)
237 = tcCoreExpr fun `thenTc` \ fun' ->
238 tcCoreExpr arg `thenTc` \ arg' ->
239 returnTc (App fun' arg')
241 tcCoreExpr (UfCase scrut case_bndr alts)
242 = tcCoreExpr scrut `thenTc` \ scrut' ->
244 scrut_ty = exprType scrut'
245 case_bndr' = mkLocalId case_bndr scrut_ty
247 tcExtendGlobalValEnv [case_bndr'] $
248 mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
249 returnTc (Case scrut' case_bndr' alts')
251 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
252 = tcCoreExpr rhs `thenTc` \ rhs' ->
253 tcCoreValBndr bndr $ \ bndr' ->
254 tcCoreExpr body `thenTc` \ body' ->
255 returnTc (Let (NonRec bndr' rhs') body')
257 tcCoreExpr (UfLet (UfRec pairs) body)
258 = tcCoreValBndrs bndrs $ \ bndrs' ->
259 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
260 tcCoreExpr body `thenTc` \ body' ->
261 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
263 (bndrs, rhss) = unzip pairs
265 tcCoreExpr (UfNote note expr)
266 = tcCoreExpr expr `thenTc` \ expr' ->
268 UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' ->
269 returnTc (Note (Coerce to_ty'
270 (exprType expr')) expr')
271 UfInlineCall -> returnTc (Note InlineCall expr')
272 UfInlineMe -> returnTc (Note InlineMe expr')
273 UfSCC cc -> returnTc (Note (SCC cc) expr')
277 tcCoreLamBndr (UfValBinder name ty) thing_inside
278 = tcIfaceType ty `thenTc` \ ty' ->
280 id = mkLocalId name ty'
282 tcExtendGlobalValEnv [id] $
285 tcCoreLamBndr (UfTyBinder name kind) thing_inside
287 tyvar = mkTyVar name kind
289 tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
291 tcCoreLamBndrs [] thing_inside = thing_inside []
292 tcCoreLamBndrs (b:bs) thing_inside
293 = tcCoreLamBndr b $ \ b' ->
294 tcCoreLamBndrs bs $ \ bs' ->
295 thing_inside (b':bs')
297 tcCoreValBndr (UfValBinder name ty) thing_inside
298 = tcIfaceType ty `thenTc` \ ty' ->
300 id = mkLocalId name ty'
302 tcExtendGlobalValEnv [id] $
305 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
306 = mapTc tcIfaceType tys `thenTc` \ tys' ->
308 ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
310 tcExtendGlobalValEnv ids $
313 names = [name | UfValBinder name _ <- bndrs]
314 tys = [ty | UfValBinder _ ty <- bndrs]
318 tcCoreAlt scrut_ty (UfDefault, names, rhs)
319 = ASSERT( null names )
320 tcCoreExpr rhs `thenTc` \ rhs' ->
321 returnTc (DEFAULT, [], rhs')
323 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
324 = ASSERT( null names )
325 tcCoreExpr rhs `thenTc` \ rhs' ->
326 returnTc (LitAlt lit, [], rhs')
328 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
329 = ASSERT( null names )
330 tcCoreExpr rhs `thenTc` \ rhs' ->
331 tcIfaceType ty `thenTc` \ ty' ->
332 returnTc (LitAlt (MachLitLit str ty'), [], rhs')
334 -- A case alternative is made quite a bit more complicated
335 -- by the fact that we omit type annotations because we can
336 -- work them out. True enough, but its not that easy!
337 tcCoreAlt scrut_ty alt@(con, names, rhs)
338 = tcConAlt con `thenTc` \ con ->
340 (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
342 (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
344 Nothing -> pprPanic "tcCoreAlt" (ppr alt)
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` 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')
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]