2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
7 module TcIfaceSig ( tcInterfaceSigs ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsDecl(..), IfaceSig(..) )
13 import TcMonoType ( tcHsType, tcHsTypeKind )
14 import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv,
15 tcLookupTyConByKey, tcLookupGlobalValueMaybe,
16 tcExplicitLookupGlobal
18 import TcKind ( TcKind, kindToTcKind )
20 import RnHsSyn ( RenamedHsDecl(..) )
22 import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
23 import Literal ( Literal(..) )
25 import CoreUtils ( coreExprType )
27 import MagicUFs ( MagicUnfoldingFun )
28 import WwLib ( mkWrapper )
29 import PrimOp ( PrimOp(..) )
31 import Id ( GenId, mkImported, mkUserId, addInlinePragma,
32 isPrimitiveId_maybe, dataConArgTys, Id )
33 import Type ( mkSynTy, splitAlgTyConApp )
34 import TyVar ( mkSysTyVar )
36 import Unique ( rationalTyConKey, uniqueOf )
37 import TysWiredIn ( integerTy )
38 import PragmaInfo ( PragmaInfo(..) )
39 import ErrUtils ( pprBagOfErrors )
40 import Maybes ( maybeToBool )
42 import Util ( zipWithEqual )
47 Ultimately, type signatures in interfaces will have pragmatic
48 information attached, so it is a good idea to have separate code to
51 As always, we do not have to worry about user-pragmas in interface
55 tcInterfaceSigs :: TcEnv s -- Envt to use when checking unfoldings
56 -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
60 tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
61 = tcAddSrcLoc src_loc (
62 tcAddErrCtxt (ifaceSigCtxt name) (
63 tcHsType ty `thenTc` \ sigma_ty ->
64 tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
66 imp_id = mkImported name sigma_ty id_info'
67 sig_id | any inline_please id_infos = addInlinePragma imp_id
70 inline_please (HsUnfold inline _) = inline
71 inline_please (HsStrictness (HsStrictnessInfo _ (Just _))) = True -- Inline wrappers
72 inline_please other = False
75 )) `thenTc` \ sig_id ->
76 tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
77 returnTc (sig_id : sig_ids)
79 tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
81 tcInterfaceSigs unf_env [] = returnTc []
85 tcIdInfo unf_env name ty info info_ins
86 = go noIdInfo info_ins
88 go info_so_far [] = returnTc info_so_far
89 go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
90 go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
91 go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
92 go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
94 go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
95 go (info `addUnfoldInfo` unfold_info) rest
97 go info (HsStrictness strict : rest) = tcStrictness unf_env ty info strict `thenTc` \ info' ->
102 tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
103 = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
104 uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
106 -- Watch out! We can't pull on maybe_worker_id too eagerly!
107 info' = case maybe_worker_id of
108 Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
110 has_worker = maybeToBool maybe_worker_id
112 returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)
114 -- Boring to write these out, but the result type differs from the arg type...
115 tcStrictness unf_env ty info HsBottom
116 = returnTc (info `addStrictnessInfo` BottomGuaranteed)
120 tcWorker unf_env Nothing = returnNF_Tc Nothing
122 tcWorker unf_env (Just (worker_name,_))
123 = returnNF_Tc (trace_maybe maybe_worker_id)
125 maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
127 -- The trace is so we can see what's getting dropped
128 trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
129 trace_maybe (Just x) = Just x
132 For unfoldings we try to do the job lazily, so that we never type check
133 an unfolding that isn't going to be looked at.
136 tcUnfolding unf_env name core_expr
138 recoverNF_Tc no_unfolding (
140 tcCoreExpr core_expr `thenTc` \ core_expr' ->
141 returnTc (mkUnfolding NoPragmaInfo core_expr')
144 -- The trace tells what wasn't available, for the benefit of
145 -- compiler hackers who want to improve it!
146 no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
147 returnNF_Tc (pprTrace "tcUnfolding failed with:"
148 (hang (ppr name) 4 (pprBagOfErrors errs))
153 Variables in unfoldings
154 ~~~~~~~~~~~~~~~~~~~~~~~
155 ****** Inside here we use only the Global environment, even for locally bound variables.
156 ****** Why? Because we know all the types and want to bind them to real Ids.
159 tcVar :: Name -> TcM s Id
161 = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id ->
163 Just id -> returnTc id;
164 Nothing -> failWithTc (noDecl name)
167 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
173 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
175 tcCoreExpr (UfVar name)
176 = tcVar name `thenTc` \ id ->
179 -- rationalTy isn't built in so we have to construct it
180 -- (the "ty" part of the incoming literal is simply bottom)
181 tcCoreExpr (UfLit (NoRepRational lit _))
182 = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
184 rational_ty = mkSynTy rational_tycon []
186 returnTc (Lit (NoRepRational lit rational_ty))
188 -- Similarly for integers, except that it is wired in
189 tcCoreExpr (UfLit (NoRepInteger lit _))
190 = returnTc (Lit (NoRepInteger lit integerTy))
192 tcCoreExpr (UfLit other_lit)
193 = returnTc (Lit other_lit)
195 tcCoreExpr (UfCon con args)
196 = tcVar con `thenTc` \ con_id ->
197 mapTc tcCoreArg args `thenTc` \ args' ->
198 returnTc (Con con_id args')
200 tcCoreExpr (UfPrim prim args)
201 = tcCorePrim prim `thenTc` \ primop ->
202 mapTc tcCoreArg args `thenTc` \ args' ->
203 returnTc (Prim primop args')
205 tcCoreExpr (UfApp fun arg)
206 = tcCoreExpr fun `thenTc` \ fun' ->
207 tcCoreArg arg `thenTc` \ arg' ->
208 returnTc (App fun' arg')
210 tcCoreExpr (UfCase scrut alts)
211 = tcCoreExpr scrut `thenTc` \ scrut' ->
212 tcCoreAlts (coreExprType scrut') alts `thenTc` \ alts' ->
213 returnTc (Case scrut' alts')
215 tcCoreExpr (UfSCC cc expr)
216 = tcCoreExpr expr `thenTc` \ expr' ->
217 returnTc (SCC cc expr')
219 tcCoreExpr(UfCoerce coercion ty body)
220 = tcCoercion coercion `thenTc` \ coercion' ->
221 tcHsTypeKind ty `thenTc` \ (_,ty') ->
222 tcCoreExpr body `thenTc` \ body' ->
223 returnTc (Coerce coercion' ty' body')
225 tcCoreExpr (UfLam bndr body)
226 = tcCoreLamBndr bndr $ \ bndr' ->
227 tcCoreExpr body `thenTc` \ body' ->
228 returnTc (Lam bndr' body')
230 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
231 = tcCoreExpr rhs `thenTc` \ rhs' ->
232 tcCoreValBndr bndr $ \ bndr' ->
233 tcCoreExpr body `thenTc` \ body' ->
234 returnTc (Let (NonRec bndr' rhs') body')
236 tcCoreExpr (UfLet (UfRec pairs) body)
237 = tcCoreValBndrs bndrs $ \ bndrs' ->
238 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
239 tcCoreExpr body `thenTc` \ body' ->
240 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
242 (bndrs, rhss) = unzip pairs
246 tcCoreLamBndr (UfValBinder name ty) thing_inside
247 = tcHsType ty `thenTc` \ ty' ->
249 id = mkUserId name ty'
251 tcExtendGlobalValEnv [id] $
252 thing_inside (ValBinder id)
254 tcCoreLamBndr (UfTyBinder name kind) thing_inside
256 tyvar = mkSysTyVar (uniqueOf name) kind
258 tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
259 thing_inside (TyBinder tyvar)
261 tcCoreValBndr (UfValBinder name ty) thing_inside
262 = tcHsType ty `thenTc` \ ty' ->
264 id = mkUserId name ty'
266 tcExtendGlobalValEnv [id] $
269 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
270 = mapTc tcHsType tys `thenTc` \ tys' ->
272 ids = zipWithEqual "tcCoreValBndr" mkUserId names tys'
274 tcExtendGlobalValEnv ids $
277 names = map (\ (UfValBinder name _) -> name) bndrs
278 tys = map (\ (UfValBinder _ ty) -> ty) bndrs
282 tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v')
283 tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty')
284 tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
286 tcCoreAlts scrut_ty (UfAlgAlts alts deflt)
287 = mapTc tc_alt alts `thenTc` \ alts' ->
288 tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
289 returnTc (AlgAlts alts' deflt')
291 tc_alt (con, names, rhs)
292 = tcVar con `thenTc` \ con' ->
294 arg_tys = dataConArgTys con' inst_tys
295 (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
296 arg_ids = zipWithEqual "tcCoreAlts" mkUserId names arg_tys
298 tcExtendGlobalValEnv arg_ids $
299 tcCoreExpr rhs `thenTc` \ rhs' ->
300 returnTc (con', arg_ids, rhs')
302 tcCoreAlts scrut_ty (UfPrimAlts alts deflt)
303 = mapTc tc_alt alts `thenTc` \ alts' ->
304 tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
305 returnTc (PrimAlts alts' deflt')
307 tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' ->
310 tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault
311 tcCoreDefault scrut_ty (UfBindDefault name rhs)
313 deflt_id = mkUserId name scrut_ty
315 tcExtendGlobalValEnv [deflt_id] $
316 tcCoreExpr rhs `thenTc` \ rhs' ->
317 returnTc (BindDefault deflt_id rhs')
320 tcCoercion (UfIn n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn n')
321 tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n')
323 tcCorePrim (UfOtherOp op)
324 = tcVar op `thenTc` \ op_id ->
325 case isPrimitiveId_maybe op_id of
326 Just prim_op -> returnTc prim_op
327 Nothing -> pprPanic "tcCorePrim" (ppr op_id)
329 tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
330 = mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
331 tcHsType res_ty `thenTc` \ res_ty' ->
332 returnTc (CCallOp str casm gc arg_tys' res_ty')
336 ifaceSigCtxt sig_name
337 = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]