ghc/compiler/typecheck/BackSubst.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[BackSubst]{Back substitution functions}
   5
   6 This module applies a typechecker substitution over the whole abstract
   7 syntax.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module BackSubst (
  13          applyTcSubstToBinds,
  14
  15          -- and to make the interface self-sufficient...
  16          Subst, Binds, MonoBinds, Id, TypecheckedPat
  17    ) where
  18
  19 IMPORT_Trace            -- ToDo: rm (debugging)
  20 import Outputable
  21 import Pretty
  22
  23 import AbsSyn
  24 import AbsUniType       ( getTyVar )
  25 import TcMonad
  26 import Util
  27 \end{code}
  28
  29 %************************************************************************
  30 %*                                                                      *
  31 \subsection[BackSubst-Binds]{Running a substitution over @Binds@}
  32 %*                                                                      *
  33 %************************************************************************
  34
  35 \begin{code}
  36 applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds
  37
  38 applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds
  39
  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)
  44
  45 applyTcSubstToBinds (SingleBind bind)
  46   = substBind bind  `thenNF_Tc` \ new_bind ->
  47     returnNF_Tc (SingleBind new_bind)
  48
  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)
  56   where
  57     subst_pair (l, g)
  58       = applyTcSubstToId l      `thenNF_Tc` \ new_l ->
  59         applyTcSubstToId g      `thenNF_Tc` \ new_g ->
  60         returnNF_Tc (new_l, new_g)
  61
  62     subst_bind (v, e)
  63       = applyTcSubstToInst v    `thenNF_Tc` \ new_v ->
  64         substExpr e             `thenNF_Tc` \ new_e ->
  65         returnNF_Tc (new_v, new_e)
  66 \end{code}
  67
  68 \begin{code}
  69 -------------------------------------------------------------------------
  70 substBind :: TypecheckedBind -> NF_TcM TypecheckedBind
  71
  72 substBind (NonRecBind mbinds)
  73   = applyTcSubstToMonoBinds mbinds      `thenNF_Tc` \ new_mbinds ->
  74     returnNF_Tc (NonRecBind new_mbinds)
  75
  76 substBind (RecBind mbinds)
  77   = applyTcSubstToMonoBinds mbinds      `thenNF_Tc` \ new_mbinds ->
  78     returnNF_Tc (RecBind new_mbinds)
  79
  80 substBind other = returnNF_Tc other
  81
  82 -------------------------------------------------------------------------
  83 applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds
  84
  85 applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
  86
  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)
  91
  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)
  96
  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)
 101
 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)
 106 \end{code}
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 \begin{code}
 115 substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch
 116
 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)
 121
 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)
 125
 126 -------------------------------------------------------------------------
 127 substGRHSsAndBinds :: TypecheckedGRHSsAndBinds
 128                    -> NF_TcM TypecheckedGRHSsAndBinds
 129
 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)
 135   where
 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)
 140
 141     subst_grhs (OtherwiseGRHS expr locn)
 142       = substExpr expr   `thenNF_Tc` \ new_expr  ->
 143         returnNF_Tc (OtherwiseGRHS new_expr locn)
 144 \end{code}
 145
 146 %************************************************************************
 147 %*                                                                      *
 148 \subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr}
 149 %*                                                                      *
 150 %************************************************************************
 151
 152 ToDo: panic on things that can't be in @TypecheckedExpr@.
 153
 154 \begin{code}
 155 substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr
 156
 157 substExpr (Var name)
 158   = applyTcSubstToId name       `thenNF_Tc` \ new_name ->
 159     returnNF_Tc (Var new_name)
 160
 161 substExpr (Lit (LitLitLit s ty))
 162   = applyTcSubstToTy ty         `thenNF_Tc` \ new_ty ->
 163     returnNF_Tc (Lit (LitLitLit s new_ty))
 164
 165 substExpr other_lit@(Lit lit) = returnNF_Tc other_lit
 166
 167 substExpr (Lam match)
 168   = substMatch match    `thenNF_Tc` \ new_match ->
 169     returnNF_Tc (Lam new_match)
 170
 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)
 175
 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)
 181
 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)
 186
 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)
 191
 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)
 196
 197 substExpr (SCC label expr)
 198   = substExpr expr      `thenNF_Tc` \ new_expr ->
 199     returnNF_Tc (SCC label new_expr)
 200
 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)
 205
 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)
 210
 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)
 215
 216 --ExplicitList: not in typechecked exprs
 217
 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)
 222
 223 substExpr (ExplicitTuple exprs)
 224   = mapNF_Tc substExpr exprs  `thenNF_Tc` \ new_exprs ->
 225     returnNF_Tc (ExplicitTuple new_exprs)
 226
 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)
 232
 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)
 237
 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)
 242
 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)
 247
 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)
 252
 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)
 257
 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)
 263
 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)
 268
 269 substExpr (SingleDict name)
 270   = applyTcSubstToId name       `thenNF_Tc` \ new_name ->
 271     returnNF_Tc (SingleDict new_name)
 272
 273 #ifdef DPH
 274
 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)
 279
 280 --substExpr (ExplicitPodIn exprs) :: not in typechecked
 281
 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)
 286
 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)
 291
 292 #endif {- Data Parallel Haskell -}
 293
 294 -------------------------------------------------------------------------
 295 substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 296
 297 substArithSeq (From e)
 298   = substExpr e         `thenNF_Tc` \ new_e ->
 299     returnNF_Tc (From new_e)
 300
 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)
 305
 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)
 310
 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)
 316
 317 -------------------------------------------------------------------------
 318 substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual]
 319
 320 substQuals quals
 321   = mapNF_Tc subst_qual quals
 322   where
 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)
 327
 328     subst_qual (FilterQual expr)
 329       = substExpr expr    `thenNF_Tc` \ new_expr ->
 330         returnNF_Tc (FilterQual new_expr)
 331
 332 -------------------------------------------------------------------------
 333 #ifdef DPH
 334 substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals
 335
 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)
 340
 341 --substParQuals (DrawnGenIn pats pat expr) :: not in typechecked
 342
 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)
 349
 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)
 355
 356 substParQuals (ParFilter expr)
 357  = substExpr expr           `thenNF_Tc` \ new_expr ->
 358    returnNF_Tc (ParFilter new_expr)
 359 #endif {- Data Parallel Haskell -}
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection[BackSubst-Pats]{Patterns}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 substPat :: TypecheckedPat -> NF_TcM TypecheckedPat
 370
 371 substPat (WildPat ty)
 372   = applyTcSubstToTy ty     `thenNF_Tc` \ new_ty ->
 373     returnNF_Tc (WildPat new_ty)
 374
 375 substPat (VarPat v)
 376   = applyTcSubstToId v      `thenNF_Tc` \ new_v ->
 377     returnNF_Tc (VarPat new_v)
 378
 379 substPat (LazyPat pat)
 380   = substPat pat            `thenNF_Tc` \ new_pat ->
 381     returnNF_Tc (LazyPat new_pat)
 382
 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)
 387
 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)
 394
 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)
 401
 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)
 406
 407 substPat (TuplePat pats)
 408   = mapNF_Tc substPat pats    `thenNF_Tc` \ new_pats ->
 409     returnNF_Tc (TuplePat new_pats)
 410
 411 substPat (LitPat lit ty)
 412   = applyTcSubstToTy ty     `thenNF_Tc` \ new_ty ->
 413     returnNF_Tc (LitPat lit new_ty)
 414
 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)
 419
 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)
 427
 428 #ifdef DPH
 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 -}
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection[BackSubst-TyVar]{Running a substitution over type variables}
 440 %*                                                                      *
 441 %************************************************************************
 442
 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.
 446
 447 \begin{code}
 448 subst_tyvars tyvars
 449   = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys ->
 450     returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys)
 451 \end{code}