2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
7 #include "HsVersions.h"
9 module TcIfaceSig ( tcInterfaceSigs ) where
14 import TcMonoType ( tcHsType, tcHsTypeKind )
15 import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
16 tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue,
17 tcExplicitLookupGlobal
19 import TcKind ( TcKind, kindToTcKind )
21 import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds,
23 import RnHsSyn ( RenamedHsDecl(..) )
25 import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
26 import Literal ( Literal(..) )
28 import CoreUtils ( coreExprType )
30 import MagicUFs ( MagicUnfoldingFun )
31 import WwLib ( mkWrapper )
32 import SpecEnv ( SpecEnv )
33 import PrimOp ( PrimOp(..) )
35 import Id ( GenId, mkImported, mkUserId, addInlinePragma,
36 isPrimitiveId_maybe, dataConArgTys, SYN_IE(Id) )
37 import Type ( mkSynTy, getAppDataTyConExpandingDicts )
38 import TyVar ( mkSysTyVar )
40 import Unique ( rationalTyConKey, uniqueOf )
41 import TysWiredIn ( integerTy )
42 import PragmaInfo ( PragmaInfo(..) )
43 import ErrUtils ( pprBagOfErrors )
44 import Maybes ( maybeToBool )
46 import Outputable ( Outputable(..), PprStyle(..) )
47 import Util ( zipWithEqual, panic, pprTrace, pprPanic )
52 Ultimately, type signatures in interfaces will have pragmatic
53 information attached, so it is a good idea to have separate code to
56 As always, we do not have to worry about user-pragmas in interface
60 tcInterfaceSigs :: TcEnv s -- Envt to use when checking unfoldings
61 -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
65 tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
66 = tcAddSrcLoc src_loc (
67 tcAddErrCtxt (ifaceSigCtxt name) (
68 tcHsType ty `thenTc` \ sigma_ty ->
69 tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
71 imp_id = mkImported name sigma_ty id_info'
72 sig_id | any inline_please id_infos = addInlinePragma imp_id
75 inline_please (HsUnfold inline _) = inline
76 inline_please other = False
79 )) `thenTc` \ sig_id ->
80 tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
81 returnTc (sig_id : sig_ids)
83 tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
85 tcInterfaceSigs unf_env [] = returnTc []
89 tcIdInfo unf_env name ty info info_ins
90 = go noIdInfo info_ins
92 go info_so_far [] = returnTc info_so_far
93 go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
94 go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
95 go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
96 go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
98 go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
99 go (info `addUnfoldInfo` unfold_info) rest
101 go info (HsStrictness strict : rest) = tcStrictness unf_env ty info strict `thenTc` \ info' ->
106 tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
107 = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
108 uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
110 -- Watch out! We can't pull on maybe_worker_id too eagerly!
111 info' = case maybe_worker_id of
112 Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
114 has_worker = maybeToBool maybe_worker_id
116 returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)
118 -- Boring to write these out, but the result type differs from the arg type...
119 tcStrictness unf_env ty info HsBottom
120 = returnTc (info `addStrictnessInfo` BottomGuaranteed)
124 tcWorker unf_env Nothing = returnNF_Tc Nothing
126 tcWorker unf_env (Just (worker_name,_))
127 = returnNF_Tc (trace_maybe maybe_worker_id)
129 maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
131 -- The trace is so we can see what's getting dropped
132 trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing
133 trace_maybe (Just x) = Just x
136 For unfoldings we try to do the job lazily, so that we never type check
137 an unfolding that isn't going to be looked at.
140 tcUnfolding unf_env name core_expr
142 recoverNF_Tc no_unfolding (
144 tcCoreExpr core_expr `thenTc` \ core_expr' ->
145 returnTc (mkUnfolding NoPragmaInfo core_expr')
148 -- The trace tells what wasn't available, for the benefit of
149 -- compiler hackers who want to improve it!
150 no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
151 returnNF_Tc (pprTrace "tcUnfolding failed with:"
152 (hang (ppr PprDebug name) 4 (pprBagOfErrors PprDebug errs))
157 Variables in unfoldings
158 ~~~~~~~~~~~~~~~~~~~~~~~
159 ****** Inside here we use only the Global environment, even for locally bound variables.
160 ****** Why? Because we know all the types and want to bind them to real Ids.
163 tcVar :: Name -> TcM s Id
165 = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id ->
167 Just id -> returnTc id;
168 Nothing -> failTc (noDecl name)
171 noDecl name sty = hsep [ptext SLIT("Warning: no binding for"), ppr sty name]
177 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
179 tcCoreExpr (UfVar name)
180 = tcVar name `thenTc` \ id ->
183 -- rationalTy isn't built in so we have to construct it
184 -- (the "ty" part of the incoming literal is simply bottom)
185 tcCoreExpr (UfLit (NoRepRational lit _))
186 = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
188 rational_ty = mkSynTy rational_tycon []
190 returnTc (Lit (NoRepRational lit rational_ty))
192 -- Similarly for integers, except that it is wired in
193 tcCoreExpr (UfLit (NoRepInteger lit _))
194 = returnTc (Lit (NoRepInteger lit integerTy))
196 tcCoreExpr (UfLit other_lit)
197 = returnTc (Lit other_lit)
199 tcCoreExpr (UfCon con args)
200 = tcVar con `thenTc` \ con_id ->
201 mapTc tcCoreArg args `thenTc` \ args' ->
202 returnTc (Con con_id args')
204 tcCoreExpr (UfPrim prim args)
205 = tcCorePrim prim `thenTc` \ primop ->
206 mapTc tcCoreArg args `thenTc` \ args' ->
207 returnTc (Prim primop args')
209 tcCoreExpr (UfApp fun arg)
210 = tcCoreExpr fun `thenTc` \ fun' ->
211 tcCoreArg arg `thenTc` \ arg' ->
212 returnTc (App fun' arg')
214 tcCoreExpr (UfCase scrut alts)
215 = tcCoreExpr scrut `thenTc` \ scrut' ->
216 tcCoreAlts (coreExprType scrut') alts `thenTc` \ alts' ->
217 returnTc (Case scrut' alts')
219 tcCoreExpr (UfSCC cc expr)
220 = tcCoreExpr expr `thenTc` \ expr' ->
221 returnTc (SCC cc expr')
223 tcCoreExpr(UfCoerce coercion ty body)
224 = tcCoercion coercion `thenTc` \ coercion' ->
225 tcHsTypeKind ty `thenTc` \ (_,ty') ->
226 tcCoreExpr body `thenTc` \ body' ->
227 returnTc (Coerce coercion' ty' body')
229 tcCoreExpr (UfLam bndr body)
230 = tcCoreLamBndr bndr $ \ bndr' ->
231 tcCoreExpr body `thenTc` \ body' ->
232 returnTc (Lam bndr' body')
234 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
235 = tcCoreExpr rhs `thenTc` \ rhs' ->
236 tcCoreValBndr bndr $ \ bndr' ->
237 tcCoreExpr body `thenTc` \ body' ->
238 returnTc (Let (NonRec bndr' rhs') body')
240 tcCoreExpr (UfLet (UfRec pairs) body)
241 = tcCoreValBndrs bndrs $ \ bndrs' ->
242 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
243 tcCoreExpr body `thenTc` \ body' ->
244 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
246 (bndrs, rhss) = unzip pairs
250 tcCoreLamBndr (UfValBinder name ty) thing_inside
251 = tcHsType ty `thenTc` \ ty' ->
253 id = mkUserId name ty' NoPragmaInfo
255 tcExtendGlobalValEnv [id] $
256 thing_inside (ValBinder id)
258 tcCoreLamBndr (UfTyBinder name kind) thing_inside
260 tyvar = mkSysTyVar (uniqueOf name) kind
262 tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
263 thing_inside (TyBinder tyvar)
265 tcCoreLamBndr (UfUsageBinder name) thing_inside
266 = error "tcCoreLamBndr: usage"
268 tcCoreValBndr (UfValBinder name ty) thing_inside
269 = tcHsType ty `thenTc` \ ty' ->
273 tcExtendGlobalValEnv [id] $
276 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
277 = mapTc tcHsType tys `thenTc` \ tys' ->
279 ids = zipWithEqual "tcCoreValBndr" mk_id names tys'
281 tcExtendGlobalValEnv ids $
284 names = map (\ (UfValBinder name _) -> name) bndrs
285 tys = map (\ (UfValBinder _ ty) -> ty) bndrs
287 mk_id name ty = mkUserId name ty NoPragmaInfo
291 tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v')
292 tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty')
293 tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
294 tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
296 tcCoreAlts scrut_ty (UfAlgAlts alts deflt)
297 = mapTc tc_alt alts `thenTc` \ alts' ->
298 tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
299 returnTc (AlgAlts alts' deflt')
301 tc_alt (con, names, rhs)
302 = tcVar con `thenTc` \ con' ->
304 arg_tys = dataConArgTys con' inst_tys
305 (tycon, inst_tys, cons) = getAppDataTyConExpandingDicts scrut_ty
306 arg_ids = zipWithEqual "tcCoreAlts" mk_id names arg_tys
308 tcExtendGlobalValEnv arg_ids $
309 tcCoreExpr rhs `thenTc` \ rhs' ->
310 returnTc (con', arg_ids, rhs')
312 tcCoreAlts scrut_ty (UfPrimAlts alts deflt)
313 = mapTc tc_alt alts `thenTc` \ alts' ->
314 tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
315 returnTc (PrimAlts alts' deflt')
317 tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' ->
320 tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault
321 tcCoreDefault scrut_ty (UfBindDefault name rhs)
323 deflt_id = mk_id name scrut_ty
325 tcExtendGlobalValEnv [deflt_id] $
326 tcCoreExpr rhs `thenTc` \ rhs' ->
327 returnTc (BindDefault deflt_id rhs')
330 tcCoercion (UfIn n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn n')
331 tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n')
333 tcCorePrim (UfOtherOp op)
334 = tcVar op `thenTc` \ op_id ->
335 case isPrimitiveId_maybe op_id of
336 Just prim_op -> returnTc prim_op
337 Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id)
339 tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
340 = mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
341 tcHsType res_ty `thenTc` \ res_ty' ->
342 returnTc (CCallOp str casm gc arg_tys' res_ty')
346 ifaceSigCtxt sig_name sty
347 = hsep [ptext SLIT("In an interface-file signature for"), ppr sty sig_name]