X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatchCon.lhs;h=ed9f89483474d12968db1ddeb15dc39209d5321e;hb=3721dd37a707d2aacb5cac814410a78096e28a2c;hp=280103b05637ec3144f6f9609bf8a119ced20a64;hpb=6c8ce61812cfc8dcc4f388d765e30d6ddab71387;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 280103b..ed9f894 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -1,28 +1,27 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 + +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[MatchCon]{Pattern-matching constructors} \begin{code} -#include "HsVersions.h" - module MatchCon ( matchConFamily ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) ( match ) -- break match-ish loop -#else -import {-# SOURCE #-} Match -#endif +#include "HsVersions.h" + +import {-# SOURCE #-} Match ( match ) -import HsSyn ( OutPat(..), HsLit, HsExpr ) -import DsHsSyn ( outPatType ) +import HsSyn ( Pat(..), HsConDetails(..) ) import DsMonad import DsUtils -import Id ( GenId{-instances-}, SYN_IE(Id) ) -import Util ( panic, assertPanic ) +import Id ( Id ) +import Subst ( mkSubst, mkInScopeSet, bindSubst, substExpr ) +import CoreFVs ( exprFreeVars ) +import VarEnv ( emptySubstEnv ) +import ListSetOps ( equivClassesByUniq ) +import SrcLoc ( unLoc ) +import Unique ( Uniquable(..) ) \end{code} We are confronted with the first column of patterns in a set of @@ -81,51 +80,61 @@ matchConFamily :: [Id] -> DsM MatchResult matchConFamily (var:vars) eqns_info - = match_cons_used vars eqns_info `thenDs` \ alts -> - mkCoAlgCaseMatchResult var alts + = let + -- Sort into equivalence classes by the unique on the constructor + -- All the EqnInfos should start with a ConPat + eqn_groups = equivClassesByUniq get_uniq eqns_info + get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con + in + -- Now make a case alternative out of each group + mappM (match_con vars) eqn_groups `thenDs` \ alts -> + + returnDs (mkCoAlgCaseMatchResult var alts) \end{code} And here is the local function that does all the work. It is more-or-less the @matchCon@/@matchClause@ functions on page~94 in Wadler's chapter in SLPJ. -\begin{code} -match_cons_used _ [{- no more eqns -}] = returnDs [] -match_cons_used vars eqns_info@(EqnInfo n ctx (ConPat data_con _ arg_pats : ps1) _ : eqns) - = let - (eqns_for_this_con, eqns_not_for_this_con) = splitByCon eqns_info - in - -- Go ahead and do the recursive call to make the alts - -- for the other ConPats in this con family... - match_cons_used vars eqns_not_for_this_con `thenDs` \ rest_of_alts -> - - -- Make new vars for the con arguments; avoid new locals where possible - selectMatchVars arg_pats `thenDs` \ new_vars -> +\begin{code} +match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _) + : other_eqns) + = -- Make new vars for the con arguments; avoid new locals where possible + mappM selectMatchVarL arg_pats `thenDs` \ arg_vars -> -- Now do the business to make the alt for _this_ ConPat ... - match (new_vars++vars) - (map shift_con_pat eqns_for_this_con) `thenDs` \ match_result -> - - returnDs ( - (data_con, new_vars, match_result) - : rest_of_alts - ) + match (arg_vars ++ vars) + (map shift_con_pat (eqn1:other_eqns)) `thenDs` \ match_result -> + + -- [See "notes on do_subst" below this function] + -- Make the ex_tvs and ex_dicts line up with those + -- in the first pattern. Remember, they are all guaranteed to be variables + let + match_result' | null ex_tvs = match_result + | null other_eqns = match_result + | otherwise = adjustMatchResult do_subst match_result + in + + returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result') where - splitByCon :: [EquationInfo] -> ([EquationInfo], [EquationInfo]) - splitByCon [] = ([],[]) - splitByCon (info@(EqnInfo _ _ (pat : _) _) : rest) - = case pat of - ConPat n _ _ | n == data_con -> (info:rest_yes, rest_no) - other_pat -> (rest_yes, info:rest_no) - where - (rest_yes, rest_no) = splitByCon rest - shift_con_pat :: EquationInfo -> EquationInfo - shift_con_pat (EqnInfo n ctx (ConPat _ _ pats': pats) match_result) - = EqnInfo n ctx (pats' ++ pats) match_result - shift_con_pat (EqnInfo n ctx (WildPat _: pats) match_result) -- Will only happen in shadow - = EqnInfo n ctx ([WildPat (outPatType arg_pat) | arg_pat <- arg_pats] ++ pats) match_result - shift_con_pat other = panic "matchConFamily:match_cons_used:shift_con_pat" + shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result) + = EqnInfo n ctx (map unLoc arg_pats ++ pats) match_result + + other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns] + + var_prs = concat [ (ex_tvs' `zip` ex_tvs) ++ + (ex_dicts' `zip` ex_dicts) + | ConPatOut _ _ _ ex_tvs' ex_dicts' <- other_pats ] + + do_subst e = substExpr subst e + where + subst = foldl (\ s (v', v) -> bindSubst s v' v) in_scope var_prs + in_scope = mkSubst (mkInScopeSet (exprFreeVars e)) emptySubstEnv + -- We put all the free variables of e into the in-scope + -- set of the substitution, not because it is necessary, + -- but to suppress the warning in Subst.lookupInScope + -- Tiresome, but doing the substitution at all is rare. \end{code} Note on @shift_con_pats@ just above: does what the list comprehension in @@ -133,3 +142,37 @@ Note on @shift_con_pats@ just above: does what the list comprehension in life. Works for @ConPats@, and we want it to fail catastrophically for anything else (which a list comprehension wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@. + + +Notes on do_subst stuff +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. Ord a => T a (a->Int) + + f (T x f) True = ...expr1... + f (T y g) False = ...expr2.. + +When we put in the tyvars etc we get + + f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... + f (T b (e::Ord a) (y::a) (g::a->Int)) True = ...expr2... + +After desugaring etc we'll get a single case: + + f = \t::T b::Bool -> + case t of + T a (d::Ord a) (x::a) (f::a->Int)) -> + case b of + True -> ...expr1... + False -> ...expr2... + +*** We have to substitute [a/b, d/e] in expr2! ** +That is what do_subst is doing. + +Originally I tried to use + (\b -> let e = d in expr2) a +to do this substitution. While this is "correct" in a way, it fails +Lint, because e::Ord b but d::Ord a. + +So now I simply do the substitution properly using substExpr. +