--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[BackSubst]{Back substitution functions}
+
+This module applies a typechecker substitution over the whole abstract
+syntax.
+
+\begin{code}
+#include "HsVersions.h"
+
+module BackSubst (
+ applyTcSubstToBinds,
+
+ -- and to make the interface self-sufficient...
+ Subst, Binds, MonoBinds, Id, TypecheckedPat
+ ) where
+
+IMPORT_Trace -- ToDo: rm (debugging)
+import Outputable
+import Pretty
+
+import AbsSyn
+import AbsUniType ( getTyVar )
+import TcMonad
+import Util
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Binds]{Running a substitution over @Binds@}
+%* *
+%************************************************************************
+
+\begin{code}
+applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds
+
+applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds
+
+applyTcSubstToBinds (ThenBinds binds1 binds2)
+ = applyTcSubstToBinds binds1 `thenNF_Tc` \ new_binds1 ->
+ applyTcSubstToBinds binds2 `thenNF_Tc` \ new_binds2 ->
+ returnNF_Tc (ThenBinds new_binds1 new_binds2)
+
+applyTcSubstToBinds (SingleBind bind)
+ = substBind bind `thenNF_Tc` \ new_bind ->
+ returnNF_Tc (SingleBind new_bind)
+
+applyTcSubstToBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
+ = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars ->
+ mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs ->
+ mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds ->
+ substBind val_bind `thenNF_Tc` \ new_val_bind ->
+ returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
+ where
+ subst_pair (l, g)
+ = applyTcSubstToId l `thenNF_Tc` \ new_l ->
+ applyTcSubstToId g `thenNF_Tc` \ new_g ->
+ returnNF_Tc (new_l, new_g)
+
+ subst_bind (v, e)
+ = applyTcSubstToInst v `thenNF_Tc` \ new_v ->
+ substExpr e `thenNF_Tc` \ new_e ->
+ returnNF_Tc (new_v, new_e)
+\end{code}
+
+\begin{code}
+-------------------------------------------------------------------------
+substBind :: TypecheckedBind -> NF_TcM TypecheckedBind
+
+substBind (NonRecBind mbinds)
+ = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
+ returnNF_Tc (NonRecBind new_mbinds)
+
+substBind (RecBind mbinds)
+ = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
+ returnNF_Tc (RecBind new_mbinds)
+
+substBind other = returnNF_Tc other
+
+-------------------------------------------------------------------------
+applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds
+
+applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
+
+applyTcSubstToMonoBinds (AndMonoBinds mbinds1 mbinds2)
+ = applyTcSubstToMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 ->
+ applyTcSubstToMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 ->
+ returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
+
+applyTcSubstToMonoBinds (PatMonoBind pat grhss_w_binds locn)
+ = substPat pat `thenNF_Tc` \ new_pat ->
+ substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+ returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
+
+applyTcSubstToMonoBinds (VarMonoBind var expr)
+ = applyTcSubstToId var `thenNF_Tc` \ new_var ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (VarMonoBind new_var new_expr)
+
+applyTcSubstToMonoBinds (FunMonoBind name ms locn)
+ = applyTcSubstToId name `thenNF_Tc` \ new_name ->
+ mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (FunMonoBind new_name new_ms locn)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
+%* *
+%************************************************************************
+
+\begin{code}
+substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch
+
+substMatch (PatMatch pat match)
+ = substPat pat `thenNF_Tc` \ new_pat ->
+ substMatch match `thenNF_Tc` \ new_match ->
+ returnNF_Tc (PatMatch new_pat new_match)
+
+substMatch (GRHSMatch grhss_w_binds)
+ = substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+ returnNF_Tc (GRHSMatch new_grhss_w_binds)
+
+-------------------------------------------------------------------------
+substGRHSsAndBinds :: TypecheckedGRHSsAndBinds
+ -> NF_TcM TypecheckedGRHSsAndBinds
+
+substGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
+ = mapNF_Tc subst_grhs grhss `thenNF_Tc` \ new_grhss ->
+ applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
+ applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
+ where
+ subst_grhs (GRHS guard expr locn)
+ = substExpr guard `thenNF_Tc` \ new_guard ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (GRHS new_guard new_expr locn)
+
+ subst_grhs (OtherwiseGRHS expr locn)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (OtherwiseGRHS new_expr locn)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr}
+%* *
+%************************************************************************
+
+ToDo: panic on things that can't be in @TypecheckedExpr@.
+
+\begin{code}
+substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr
+
+substExpr (Var name)
+ = applyTcSubstToId name `thenNF_Tc` \ new_name ->
+ returnNF_Tc (Var new_name)
+
+substExpr (Lit (LitLitLit s ty))
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (Lit (LitLitLit s new_ty))
+
+substExpr other_lit@(Lit lit) = returnNF_Tc other_lit
+
+substExpr (Lam match)
+ = substMatch match `thenNF_Tc` \ new_match ->
+ returnNF_Tc (Lam new_match)
+
+substExpr (App e1 e2)
+ = substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (App new_e1 new_e2)
+
+substExpr (OpApp e1 op e2)
+ = substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr op `thenNF_Tc` \ new_op ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (OpApp new_e1 new_op new_e2)
+
+substExpr (SectionL expr op)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ substExpr op `thenNF_Tc` \ new_op ->
+ returnNF_Tc (SectionL new_expr new_op)
+
+substExpr (SectionR op expr)
+ = substExpr op `thenNF_Tc` \ new_op ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SectionR new_op new_expr)
+
+substExpr (CCall fun args may_gc is_casm result_ty)
+ = mapNF_Tc substExpr args `thenNF_Tc` \ new_args ->
+ applyTcSubstToTy result_ty `thenNF_Tc` \ new_result_ty ->
+ returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+
+substExpr (SCC label expr)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SCC label new_expr)
+
+substExpr (Case expr ms)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (Case new_expr new_ms)
+
+substExpr (ListComp expr quals)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ substQuals quals `thenNF_Tc` \ new_quals ->
+ returnNF_Tc (ListComp new_expr new_quals)
+
+substExpr (Let binds expr)
+ = applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (Let new_binds new_expr)
+
+--ExplicitList: not in typechecked exprs
+
+substExpr (ExplicitListOut ty exprs)
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitListOut new_ty new_exprs)
+
+substExpr (ExplicitTuple exprs)
+ = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitTuple new_exprs)
+
+substExpr (If e1 e2 e3)
+ = substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ substExpr e3 `thenNF_Tc` \ new_e3 ->
+ returnNF_Tc (If new_e1 new_e2 new_e3)
+
+substExpr (ArithSeqOut expr info)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ substArithSeq info `thenNF_Tc` \ new_info ->
+ returnNF_Tc (ArithSeqOut new_expr new_info)
+
+substExpr (TyLam tyvars expr)
+ = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (TyLam new_tyvars new_expr)
+
+substExpr (TyApp expr tys)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc (applyTcSubstToTy) tys `thenNF_Tc` \ new_tys ->
+ returnNF_Tc (TyApp new_expr new_tys)
+
+substExpr (DictLam dicts expr)
+ = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (DictLam new_dicts new_expr)
+
+substExpr (DictApp expr dicts)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
+ returnNF_Tc (DictApp new_expr new_dicts)
+
+substExpr (ClassDictLam dicts methods expr)
+ = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
+
+substExpr (Dictionary dicts methods)
+ = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
+ returnNF_Tc (Dictionary new_dicts new_methods)
+
+substExpr (SingleDict name)
+ = applyTcSubstToId name `thenNF_Tc` \ new_name ->
+ returnNF_Tc (SingleDict new_name)
+
+#ifdef DPH
+
+substExpr (ParallelZF expr quals)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ substParQuals quals `thenNF_Tc` \ new_quals ->
+ returnNF_Tc (ParallelZF new_expr new_quals)
+
+--substExpr (ExplicitPodIn exprs) :: not in typechecked
+
+substExpr (ExplicitPodOut ty exprs)
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitPodOut new_ty new_exprs)
+
+substExpr (ExplicitProcessor exprs expr)
+ = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (ExplicitProcessor new_exprs new_expr)
+
+#endif {- Data Parallel Haskell -}
+
+-------------------------------------------------------------------------
+substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
+
+substArithSeq (From e)
+ = substExpr e `thenNF_Tc` \ new_e ->
+ returnNF_Tc (From new_e)
+
+substArithSeq (FromThen e1 e2)
+ = substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (FromThen new_e1 new_e2)
+
+substArithSeq (FromTo e1 e2)
+ = substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (FromTo new_e1 new_e2)
+
+substArithSeq (FromThenTo e1 e2 e3)
+ = substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ substExpr e3 `thenNF_Tc` \ new_e3 ->
+ returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
+
+-------------------------------------------------------------------------
+substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual]
+
+substQuals quals
+ = mapNF_Tc subst_qual quals
+ where
+ subst_qual (GeneratorQual pat expr)
+ = substPat pat `thenNF_Tc` \ new_pat ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (GeneratorQual new_pat new_expr)
+
+ subst_qual (FilterQual expr)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (FilterQual new_expr)
+
+-------------------------------------------------------------------------
+#ifdef DPH
+substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals
+
+substParQuals (AndParQuals quals1 quals2)
+ = substParQuals quals1 `thenNF_Tc` \ new_quals1 ->
+ substParQuals quals2 `thenNF_Tc` \ new_quals2 ->
+ returnNF_Tc (AndParQuals new_quals1 new_quals2)
+
+--substParQuals (DrawnGenIn pats pat expr) :: not in typechecked
+
+substParQuals (DrawnGenOut pats convs pat expr)
+ = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
+ mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs ->
+ substPat pat `thenNF_Tc` \ new_pat ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (DrawnGenOut new_pats new_convs new_pat new_expr)
+
+substParQuals (IndexGen pats pat expr)
+ = mapNF_Tc substExpr pats `thenNF_Tc` \ new_pats ->
+ substPat pat `thenNF_Tc` \ new_pat ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (IndexGen new_pats new_pat new_expr)
+
+substParQuals (ParFilter expr)
+ = substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (ParFilter new_expr)
+#endif {- Data Parallel Haskell -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Pats]{Patterns}
+%* *
+%************************************************************************
+
+\begin{code}
+substPat :: TypecheckedPat -> NF_TcM TypecheckedPat
+
+substPat (WildPat ty)
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (WildPat new_ty)
+
+substPat (VarPat v)
+ = applyTcSubstToId v `thenNF_Tc` \ new_v ->
+ returnNF_Tc (VarPat new_v)
+
+substPat (LazyPat pat)
+ = substPat pat `thenNF_Tc` \ new_pat ->
+ returnNF_Tc (LazyPat new_pat)
+
+substPat (AsPat n pat)
+ = applyTcSubstToId n `thenNF_Tc` \ new_n ->
+ substPat pat `thenNF_Tc` \ new_pat ->
+ returnNF_Tc (AsPat new_n new_pat)
+
+substPat (ConPat n ty pats)
+ = applyTcSubstToId n `thenNF_Tc` \ new_n ->
+ -- ToDo: "n"'s global, so omit?
+ applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
+ returnNF_Tc (ConPat new_n new_ty new_pats)
+
+substPat (ConOpPat pat1 op pat2 ty)
+ = substPat pat1 `thenNF_Tc` \ new_pat1 ->
+ applyTcSubstToId op `thenNF_Tc` \ new_op ->
+ substPat pat2 `thenNF_Tc` \ new_pat2 ->
+ applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (ConOpPat new_pat1 new_op new_pat2 new_ty)
+
+substPat (ListPat ty pats)
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
+ returnNF_Tc (ListPat new_ty new_pats)
+
+substPat (TuplePat pats)
+ = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
+ returnNF_Tc (TuplePat new_pats)
+
+substPat (LitPat lit ty)
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (LitPat lit new_ty)
+
+substPat (NPat lit ty expr)
+ = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ substExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (NPat lit new_ty new_expr)
+
+substPat (NPlusKPat n k ty e1 e2 e3)
+ = applyTcSubstToId n `thenNF_Tc` \ new_n ->
+ applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
+ substExpr e1 `thenNF_Tc` \ new_e1 ->
+ substExpr e2 `thenNF_Tc` \ new_e2 ->
+ substExpr e3 `thenNF_Tc` \ new_e3 ->
+ returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2 new_e3)
+
+#ifdef DPH
+substPat (ProcessorPat pats convs pat)
+ = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
+ mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs ->
+ substPat pat `thenNF_Tc` \ new_pat ->
+ returnNF_Tc (ProcessorPat new_pats new_convs new_pat)
+#endif {- Data Parallel Haskell -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-TyVar]{Running a substitution over type variables}
+%* *
+%************************************************************************
+
+The type variables in an @AbsBinds@ or @TyLam@ may have a binding in the
+substitution as a result of a @matchTy@ call. So we should subsitute for
+them too. The result should certainly be a type variable.
+
+\begin{code}
+subst_tyvars tyvars
+ = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys ->
+ returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys)
+\end{code}
projects / ghc-hetmet.git / blobdiff