2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[BackSubst]{Back substitution functions}
6 This module applies a typechecker substitution over the whole abstract
10 #include "HsVersions.h"
15 -- and to make the interface self-sufficient...
16 Subst, Binds, MonoBinds, Id, TypecheckedPat
19 IMPORT_Trace -- ToDo: rm (debugging)
24 import AbsUniType ( getTyVar )
29 %************************************************************************
31 \subsection[BackSubst-Binds]{Running a substitution over @Binds@}
33 %************************************************************************
36 applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds
38 applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds
40 applyTcSubstToBinds (ThenBinds binds1 binds2)
41 = applyTcSubstToBinds binds1 `thenNF_Tc` \ new_binds1 ->
42 applyTcSubstToBinds binds2 `thenNF_Tc` \ new_binds2 ->
43 returnNF_Tc (ThenBinds new_binds1 new_binds2)
45 applyTcSubstToBinds (SingleBind bind)
46 = substBind bind `thenNF_Tc` \ new_bind ->
47 returnNF_Tc (SingleBind new_bind)
49 applyTcSubstToBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
50 = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars ->
51 mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
52 mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs ->
53 mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds ->
54 substBind val_bind `thenNF_Tc` \ new_val_bind ->
55 returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
58 = applyTcSubstToId l `thenNF_Tc` \ new_l ->
59 applyTcSubstToId g `thenNF_Tc` \ new_g ->
60 returnNF_Tc (new_l, new_g)
63 = applyTcSubstToInst v `thenNF_Tc` \ new_v ->
64 substExpr e `thenNF_Tc` \ new_e ->
65 returnNF_Tc (new_v, new_e)
69 -------------------------------------------------------------------------
70 substBind :: TypecheckedBind -> NF_TcM TypecheckedBind
72 substBind (NonRecBind mbinds)
73 = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
74 returnNF_Tc (NonRecBind new_mbinds)
76 substBind (RecBind mbinds)
77 = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
78 returnNF_Tc (RecBind new_mbinds)
80 substBind other = returnNF_Tc other
82 -------------------------------------------------------------------------
83 applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds
85 applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
87 applyTcSubstToMonoBinds (AndMonoBinds mbinds1 mbinds2)
88 = applyTcSubstToMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 ->
89 applyTcSubstToMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 ->
90 returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
92 applyTcSubstToMonoBinds (PatMonoBind pat grhss_w_binds locn)
93 = substPat pat `thenNF_Tc` \ new_pat ->
94 substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
95 returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
97 applyTcSubstToMonoBinds (VarMonoBind var expr)
98 = applyTcSubstToId var `thenNF_Tc` \ new_var ->
99 substExpr expr `thenNF_Tc` \ new_expr ->
100 returnNF_Tc (VarMonoBind new_var new_expr)
102 applyTcSubstToMonoBinds (FunMonoBind name ms locn)
103 = applyTcSubstToId name `thenNF_Tc` \ new_name ->
104 mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms ->
105 returnNF_Tc (FunMonoBind new_name new_ms locn)
108 %************************************************************************
110 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
112 %************************************************************************
115 substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch
117 substMatch (PatMatch pat match)
118 = substPat pat `thenNF_Tc` \ new_pat ->
119 substMatch match `thenNF_Tc` \ new_match ->
120 returnNF_Tc (PatMatch new_pat new_match)
122 substMatch (GRHSMatch grhss_w_binds)
123 = substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
124 returnNF_Tc (GRHSMatch new_grhss_w_binds)
126 -------------------------------------------------------------------------
127 substGRHSsAndBinds :: TypecheckedGRHSsAndBinds
128 -> NF_TcM TypecheckedGRHSsAndBinds
130 substGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
131 = mapNF_Tc subst_grhs grhss `thenNF_Tc` \ new_grhss ->
132 applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
133 applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
134 returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
136 subst_grhs (GRHS guard expr locn)
137 = substExpr guard `thenNF_Tc` \ new_guard ->
138 substExpr expr `thenNF_Tc` \ new_expr ->
139 returnNF_Tc (GRHS new_guard new_expr locn)
141 subst_grhs (OtherwiseGRHS expr locn)
142 = substExpr expr `thenNF_Tc` \ new_expr ->
143 returnNF_Tc (OtherwiseGRHS new_expr locn)
146 %************************************************************************
148 \subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr}
150 %************************************************************************
152 ToDo: panic on things that can't be in @TypecheckedExpr@.
155 substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr
158 = applyTcSubstToId name `thenNF_Tc` \ new_name ->
159 returnNF_Tc (Var new_name)
161 substExpr (Lit (LitLitLit s ty))
162 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
163 returnNF_Tc (Lit (LitLitLit s new_ty))
165 substExpr other_lit@(Lit lit) = returnNF_Tc other_lit
167 substExpr (Lam match)
168 = substMatch match `thenNF_Tc` \ new_match ->
169 returnNF_Tc (Lam new_match)
171 substExpr (App e1 e2)
172 = substExpr e1 `thenNF_Tc` \ new_e1 ->
173 substExpr e2 `thenNF_Tc` \ new_e2 ->
174 returnNF_Tc (App new_e1 new_e2)
176 substExpr (OpApp e1 op e2)
177 = substExpr e1 `thenNF_Tc` \ new_e1 ->
178 substExpr op `thenNF_Tc` \ new_op ->
179 substExpr e2 `thenNF_Tc` \ new_e2 ->
180 returnNF_Tc (OpApp new_e1 new_op new_e2)
182 substExpr (SectionL expr op)
183 = substExpr expr `thenNF_Tc` \ new_expr ->
184 substExpr op `thenNF_Tc` \ new_op ->
185 returnNF_Tc (SectionL new_expr new_op)
187 substExpr (SectionR op expr)
188 = substExpr op `thenNF_Tc` \ new_op ->
189 substExpr expr `thenNF_Tc` \ new_expr ->
190 returnNF_Tc (SectionR new_op new_expr)
192 substExpr (CCall fun args may_gc is_casm result_ty)
193 = mapNF_Tc substExpr args `thenNF_Tc` \ new_args ->
194 applyTcSubstToTy result_ty `thenNF_Tc` \ new_result_ty ->
195 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
197 substExpr (SCC label expr)
198 = substExpr expr `thenNF_Tc` \ new_expr ->
199 returnNF_Tc (SCC label new_expr)
201 substExpr (Case expr ms)
202 = substExpr expr `thenNF_Tc` \ new_expr ->
203 mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms ->
204 returnNF_Tc (Case new_expr new_ms)
206 substExpr (ListComp expr quals)
207 = substExpr expr `thenNF_Tc` \ new_expr ->
208 substQuals quals `thenNF_Tc` \ new_quals ->
209 returnNF_Tc (ListComp new_expr new_quals)
211 substExpr (Let binds expr)
212 = applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
213 substExpr expr `thenNF_Tc` \ new_expr ->
214 returnNF_Tc (Let new_binds new_expr)
216 --ExplicitList: not in typechecked exprs
218 substExpr (ExplicitListOut ty exprs)
219 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
220 mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
221 returnNF_Tc (ExplicitListOut new_ty new_exprs)
223 substExpr (ExplicitTuple exprs)
224 = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
225 returnNF_Tc (ExplicitTuple new_exprs)
227 substExpr (If e1 e2 e3)
228 = substExpr e1 `thenNF_Tc` \ new_e1 ->
229 substExpr e2 `thenNF_Tc` \ new_e2 ->
230 substExpr e3 `thenNF_Tc` \ new_e3 ->
231 returnNF_Tc (If new_e1 new_e2 new_e3)
233 substExpr (ArithSeqOut expr info)
234 = substExpr expr `thenNF_Tc` \ new_expr ->
235 substArithSeq info `thenNF_Tc` \ new_info ->
236 returnNF_Tc (ArithSeqOut new_expr new_info)
238 substExpr (TyLam tyvars expr)
239 = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars ->
240 substExpr expr `thenNF_Tc` \ new_expr ->
241 returnNF_Tc (TyLam new_tyvars new_expr)
243 substExpr (TyApp expr tys)
244 = substExpr expr `thenNF_Tc` \ new_expr ->
245 mapNF_Tc (applyTcSubstToTy) tys `thenNF_Tc` \ new_tys ->
246 returnNF_Tc (TyApp new_expr new_tys)
248 substExpr (DictLam dicts expr)
249 = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
250 substExpr expr `thenNF_Tc` \ new_expr ->
251 returnNF_Tc (DictLam new_dicts new_expr)
253 substExpr (DictApp expr dicts)
254 = substExpr expr `thenNF_Tc` \ new_expr ->
255 mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
256 returnNF_Tc (DictApp new_expr new_dicts)
258 substExpr (ClassDictLam dicts methods expr)
259 = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
260 mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
261 substExpr expr `thenNF_Tc` \ new_expr ->
262 returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
264 substExpr (Dictionary dicts methods)
265 = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
266 mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
267 returnNF_Tc (Dictionary new_dicts new_methods)
269 substExpr (SingleDict name)
270 = applyTcSubstToId name `thenNF_Tc` \ new_name ->
271 returnNF_Tc (SingleDict new_name)
275 substExpr (ParallelZF expr quals)
276 = substExpr expr `thenNF_Tc` \ new_expr ->
277 substParQuals quals `thenNF_Tc` \ new_quals ->
278 returnNF_Tc (ParallelZF new_expr new_quals)
280 --substExpr (ExplicitPodIn exprs) :: not in typechecked
282 substExpr (ExplicitPodOut ty exprs)
283 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
284 mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
285 returnNF_Tc (ExplicitPodOut new_ty new_exprs)
287 substExpr (ExplicitProcessor exprs expr)
288 = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
289 substExpr expr `thenNF_Tc` \ new_expr ->
290 returnNF_Tc (ExplicitProcessor new_exprs new_expr)
292 #endif {- Data Parallel Haskell -}
294 -------------------------------------------------------------------------
295 substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
297 substArithSeq (From e)
298 = substExpr e `thenNF_Tc` \ new_e ->
299 returnNF_Tc (From new_e)
301 substArithSeq (FromThen e1 e2)
302 = substExpr e1 `thenNF_Tc` \ new_e1 ->
303 substExpr e2 `thenNF_Tc` \ new_e2 ->
304 returnNF_Tc (FromThen new_e1 new_e2)
306 substArithSeq (FromTo e1 e2)
307 = substExpr e1 `thenNF_Tc` \ new_e1 ->
308 substExpr e2 `thenNF_Tc` \ new_e2 ->
309 returnNF_Tc (FromTo new_e1 new_e2)
311 substArithSeq (FromThenTo e1 e2 e3)
312 = substExpr e1 `thenNF_Tc` \ new_e1 ->
313 substExpr e2 `thenNF_Tc` \ new_e2 ->
314 substExpr e3 `thenNF_Tc` \ new_e3 ->
315 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
317 -------------------------------------------------------------------------
318 substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual]
321 = mapNF_Tc subst_qual quals
323 subst_qual (GeneratorQual pat expr)
324 = substPat pat `thenNF_Tc` \ new_pat ->
325 substExpr expr `thenNF_Tc` \ new_expr ->
326 returnNF_Tc (GeneratorQual new_pat new_expr)
328 subst_qual (FilterQual expr)
329 = substExpr expr `thenNF_Tc` \ new_expr ->
330 returnNF_Tc (FilterQual new_expr)
332 -------------------------------------------------------------------------
334 substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals
336 substParQuals (AndParQuals quals1 quals2)
337 = substParQuals quals1 `thenNF_Tc` \ new_quals1 ->
338 substParQuals quals2 `thenNF_Tc` \ new_quals2 ->
339 returnNF_Tc (AndParQuals new_quals1 new_quals2)
341 --substParQuals (DrawnGenIn pats pat expr) :: not in typechecked
343 substParQuals (DrawnGenOut pats convs pat expr)
344 = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
345 mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs ->
346 substPat pat `thenNF_Tc` \ new_pat ->
347 substExpr expr `thenNF_Tc` \ new_expr ->
348 returnNF_Tc (DrawnGenOut new_pats new_convs new_pat new_expr)
350 substParQuals (IndexGen pats pat expr)
351 = mapNF_Tc substExpr pats `thenNF_Tc` \ new_pats ->
352 substPat pat `thenNF_Tc` \ new_pat ->
353 substExpr expr `thenNF_Tc` \ new_expr ->
354 returnNF_Tc (IndexGen new_pats new_pat new_expr)
356 substParQuals (ParFilter expr)
357 = substExpr expr `thenNF_Tc` \ new_expr ->
358 returnNF_Tc (ParFilter new_expr)
359 #endif {- Data Parallel Haskell -}
362 %************************************************************************
364 \subsection[BackSubst-Pats]{Patterns}
366 %************************************************************************
369 substPat :: TypecheckedPat -> NF_TcM TypecheckedPat
371 substPat (WildPat ty)
372 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
373 returnNF_Tc (WildPat new_ty)
376 = applyTcSubstToId v `thenNF_Tc` \ new_v ->
377 returnNF_Tc (VarPat new_v)
379 substPat (LazyPat pat)
380 = substPat pat `thenNF_Tc` \ new_pat ->
381 returnNF_Tc (LazyPat new_pat)
383 substPat (AsPat n pat)
384 = applyTcSubstToId n `thenNF_Tc` \ new_n ->
385 substPat pat `thenNF_Tc` \ new_pat ->
386 returnNF_Tc (AsPat new_n new_pat)
388 substPat (ConPat n ty pats)
389 = applyTcSubstToId n `thenNF_Tc` \ new_n ->
390 -- ToDo: "n"'s global, so omit?
391 applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
392 mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
393 returnNF_Tc (ConPat new_n new_ty new_pats)
395 substPat (ConOpPat pat1 op pat2 ty)
396 = substPat pat1 `thenNF_Tc` \ new_pat1 ->
397 applyTcSubstToId op `thenNF_Tc` \ new_op ->
398 substPat pat2 `thenNF_Tc` \ new_pat2 ->
399 applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
400 returnNF_Tc (ConOpPat new_pat1 new_op new_pat2 new_ty)
402 substPat (ListPat ty pats)
403 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
404 mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
405 returnNF_Tc (ListPat new_ty new_pats)
407 substPat (TuplePat pats)
408 = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
409 returnNF_Tc (TuplePat new_pats)
411 substPat (LitPat lit ty)
412 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
413 returnNF_Tc (LitPat lit new_ty)
415 substPat (NPat lit ty expr)
416 = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
417 substExpr expr `thenNF_Tc` \ new_expr ->
418 returnNF_Tc (NPat lit new_ty new_expr)
420 substPat (NPlusKPat n k ty e1 e2 e3)
421 = applyTcSubstToId n `thenNF_Tc` \ new_n ->
422 applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
423 substExpr e1 `thenNF_Tc` \ new_e1 ->
424 substExpr e2 `thenNF_Tc` \ new_e2 ->
425 substExpr e3 `thenNF_Tc` \ new_e3 ->
426 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2 new_e3)
429 substPat (ProcessorPat pats convs pat)
430 = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
431 mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs ->
432 substPat pat `thenNF_Tc` \ new_pat ->
433 returnNF_Tc (ProcessorPat new_pats new_convs new_pat)
434 #endif {- Data Parallel Haskell -}
437 %************************************************************************
439 \subsection[BackSubst-TyVar]{Running a substitution over type variables}
441 %************************************************************************
443 The type variables in an @AbsBinds@ or @TyLam@ may have a binding in the
444 substitution as a result of a @matchTy@ call. So we should subsitute for
445 them too. The result should certainly be a type variable.
449 = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys ->
450 returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys)