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 )
15 import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv )
16 import TcKind ( TcKind, kindToTcKind )
18 import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds,
20 import RnHsSyn ( RenamedHsDecl(..) )
22 import HsDecls ( HsIdInfo(..) )
25 import MagicUFs ( MagicUnfoldingFun )
26 import SpecEnv ( SpecEnv )
27 import PrimOp ( PrimOp(..) )
29 import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe )
30 import TyVar ( mkTyVar )
32 import PragmaInfo ( PragmaInfo(..) )
33 import Maybes ( maybeToBool )
35 import PprStyle ( PprStyle(..) )
36 import Util ( zipWithEqual, panic, pprTrace, pprPanic )
41 Ultimately, type signatures in interfaces will have pragmatic
42 information attached, so it is a good idea to have separate code to
45 As always, we do not have to worry about user-pragmas in interface
49 tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
50 -- Ignore non-sig-decls in these decls
52 tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
53 = tcAddSrcLoc src_loc $
54 tcHsType ty `thenTc` \ sigma_ty ->
55 tcIdInfo name noIdInfo id_infos `thenTc` \ id_info' ->
57 sig_id = mkImported name sigma_ty id_info'
59 tcInterfaceSigs rest `thenTc` \ sig_ids ->
60 returnTc (sig_id : sig_ids)
62 tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
64 tcInterfaceSigs [] = returnTc []
67 Inside here we use only the Global environment, even for locally bound variables.
68 Why? Because we know all the types and want to bind them to real Ids.
71 tcIdInfo name info [] = returnTc info
73 tcIdInfo name info (HsArity arity : rest)
74 = tcIdInfo name (info `addArityInfo` arity) rest
76 tcIdInfo name info (HsUpdate upd : rest)
77 = tcIdInfo name (info `addUpdateInfo` upd) rest
79 tcIdInfo name info (HsFBType fb : rest)
80 = tcIdInfo name (info `addFBTypeInfo` fb) rest
82 tcIdInfo name info (HsArgUsage au : rest)
83 = tcIdInfo name (info `addArgUsageInfo` au) rest
85 tcIdInfo name info (HsDeforest df : rest)
86 = tcIdInfo name (info `addDeforestInfo` df) rest
88 tcIdInfo name info (HsUnfold expr : rest)
89 = tcUnfolding name expr `thenNF_Tc` \ unfold_info ->
90 tcIdInfo name (info `addUnfoldInfo` unfold_info) rest
92 tcIdInfo name info (HsStrictness strict : rest)
93 = tcStrictness strict `thenTc` \ strict_info ->
94 tcIdInfo name (info `addStrictnessInfo` strict_info) rest
98 tcStrictness (StrictnessInfo demands (Just worker))
99 = tcLookupGlobalValue worker `thenNF_Tc` \ worker_id ->
100 returnTc (StrictnessInfo demands (Just worker_id))
102 -- Boring to write these out, but the result type differe from the arg type...
103 tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing)
104 tcStrictness NoStrictnessInfo = returnTc NoStrictnessInfo
105 tcStrictness BottomGuaranteed = returnTc BottomGuaranteed
108 For unfoldings we try to do the job lazily, so that we never type check
109 an unfolding that isn't going to be looked at.
112 tcUnfolding name core_expr
114 recoverNF_Tc (returnNF_Tc no_unfolding) (
115 tcCoreExpr core_expr `thenTc` \ core_expr' ->
116 returnTc (mkUnfolding False core_expr')
119 no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding
125 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
127 tcCoreExpr (UfVar name)
128 = tcLookupGlobalValue name `thenNF_Tc` \ id ->
131 tcCoreExpr (UfLit lit) = returnTc (Lit lit)
133 tcCoreExpr (UfCon con args)
134 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
135 mapTc tcCoreArg args `thenTc` \ args' ->
136 returnTc (Con con_id args')
138 tcCoreExpr (UfPrim prim args)
139 = tcCorePrim prim `thenTc` \ primop ->
140 mapTc tcCoreArg args `thenTc` \ args' ->
141 returnTc (Prim primop args')
143 tcCoreExpr (UfApp fun arg)
144 = tcCoreExpr fun `thenTc` \ fun' ->
145 tcCoreArg arg `thenTc` \ arg' ->
146 returnTc (App fun' arg')
148 tcCoreExpr (UfCase scrut alts)
149 = tcCoreExpr scrut `thenTc` \ scrut' ->
150 tcCoreAlts alts `thenTc` \ alts' ->
151 returnTc (Case scrut' alts')
153 tcCoreExpr (UfSCC cc expr)
154 = tcCoreExpr expr `thenTc` \ expr' ->
155 returnTc (SCC cc expr')
157 tcCoreExpr(UfCoerce coercion ty body)
158 = tcCoercion coercion `thenTc` \ coercion' ->
159 tcHsType ty `thenTc` \ ty' ->
160 tcCoreExpr body `thenTc` \ body' ->
161 returnTc (Coerce coercion' ty' body')
163 tcCoreExpr (UfLam bndr body)
164 = tcCoreLamBndr bndr $ \ bndr' ->
165 tcCoreExpr body `thenTc` \ body' ->
166 returnTc (Lam bndr' body')
168 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
169 = tcCoreExpr rhs `thenTc` \ rhs' ->
170 tcCoreValBndr bndr $ \ bndr' ->
171 tcCoreExpr body `thenTc` \ body' ->
172 returnTc (Let (NonRec bndr' rhs') body')
174 tcCoreExpr (UfLet (UfRec pairs) body)
175 = tcCoreValBndrs bndrs $ \ bndrs' ->
176 mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
177 tcCoreExpr body `thenTc` \ body' ->
178 returnTc (Let (Rec (bndrs' `zip` rhss')) body')
180 (bndrs, rhss) = unzip pairs
184 tcCoreLamBndr (UfValBinder name ty) thing_inside
185 = tcHsType ty `thenTc` \ ty' ->
187 id = mkUserId name ty' NoPragmaInfo
189 tcExtendGlobalValEnv [id] $
190 thing_inside (ValBinder id)
192 tcCoreLamBndr (UfTyBinder name kind) thing_inside
194 tyvar = mkTyVar name kind
196 tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
197 thing_inside (TyBinder tyvar)
199 tcCoreLamBndr (UfUsageBinder name) thing_inside
200 = error "tcCoreLamBndr: usage"
202 tcCoreValBndr (UfValBinder name ty) thing_inside
203 = tcHsType ty `thenTc` \ ty' ->
205 id = mkUserId name ty' NoPragmaInfo
207 tcExtendGlobalValEnv [id] $
210 tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
211 = mapTc tcHsType tys `thenTc` \ tys' ->
213 ids = zipWithEqual "tcCoreValBndr" mk_id names tys'
214 mk_id name ty' = mkUserId name ty' NoPragmaInfo
216 tcExtendGlobalValEnv ids $
219 names = map (\ (UfValBinder name _) -> name) bndrs
220 tys = map (\ (UfValBinder _ ty) -> ty) bndrs
224 tcCoreArg (UfVarArg v) = tcLookupGlobalValue v `thenNF_Tc` \ v' -> returnTc (VarArg v')
225 tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty')
226 tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
227 tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
229 tcCoreAlts (UfAlgAlts alts deflt)
230 = mapTc tc_alt alts `thenTc` \ alts' ->
231 tcCoreDefault deflt `thenTc` \ deflt' ->
232 returnTc (AlgAlts alts' deflt')
234 tc_alt (con, bndrs, rhs) = tcLookupGlobalValue con `thenNF_Tc` \ con' ->
235 tcCoreValBndrs bndrs $ \ bndrs' ->
236 tcCoreExpr rhs `thenTc` \ rhs' ->
237 returnTc (con', bndrs', rhs')
239 tcCoreAlts (UfPrimAlts alts deflt)
240 = mapTc tc_alt alts `thenTc` \ alts' ->
241 tcCoreDefault deflt `thenTc` \ deflt' ->
242 returnTc (PrimAlts alts' deflt')
244 tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' ->
247 tcCoreDefault UfNoDefault = returnTc NoDefault
248 tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr $ \ bndr' ->
249 tcCoreExpr rhs `thenTc` \ rhs' ->
250 returnTc (BindDefault bndr' rhs')
252 tcCoercion (UfIn n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn n')
253 tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n')
255 tcCorePrim (UfOtherOp op)
256 = tcLookupGlobalValue op `thenNF_Tc` \ op_id ->
257 case isPrimitiveId_maybe op_id of
258 Just prim_op -> returnTc prim_op
259 Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id)
261 tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
262 = mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
263 tcHsType res_ty `thenTc` \ res_ty' ->
264 returnTc (CCallOp str casm gc arg_tys' res_ty')