X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatchCon.lhs;h=a84c96d198cc08fabf27dd60782ef06d9189ab45;hb=ed75b2fd12799f62ea76ae43ebaa46d04f70db3d;hp=a87421898259d9f0c8ecfd08d0dbeaed9e8cdae3;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index a874218..a84c96d 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -10,17 +10,21 @@ module MatchCon ( matchConFamily ) where import {-# SOURCE #-} Match ( match ) -import HsSyn ( Pat(..), HsConDetails(..) ) - +import HsSyn ( Pat(..), HsConDetails(..), isEmptyLHsBinds ) +import DsBinds ( dsHsNestedBinds ) +import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) +import TcType ( tcTyConAppArgs ) +import Type ( substTys, zipTopTvSubst, mkTyVarTys ) +import CoreSyn import DsMonad import DsUtils import Id ( Id ) -import Subst ( mkSubst, mkInScopeSet, bindSubst, substExpr ) -import CoreFVs ( exprFreeVars ) -import VarEnv ( emptySubstEnv ) +import Type ( Type ) import ListSetOps ( equivClassesByUniq ) +import SrcLoc ( unLoc, Located(..) ) import Unique ( Uniquable(..) ) +import Outputable \end{code} We are confronted with the first column of patterns in a set of @@ -75,76 +79,69 @@ have-we-used-all-the-constructors? question; the local function @match_cons_used@ does all the real work. \begin{code} matchConFamily :: [Id] + -> Type -> [EquationInfo] -> DsM MatchResult - -matchConFamily (var:vars) eqns_info +matchConFamily (var:vars) ty eqns_info = 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 + groups = equivClassesByUniq get_uniq eqns_info + get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con + + -- Get the wrapper from the head of each group. We're going to + -- use it as the pattern in this case expression, so we need to + -- ensure that any type variables it mentions in the pattern are + -- in scope. So we put its wrappers outside the case, and + -- zap the wrapper for it. + wraps :: [CoreExpr -> CoreExpr] + wraps = map (eqn_wrap . head) groups + + groups' = [ eqn { eqn_wrap = idWrapper } : eqns | eqn:eqns <- groups ] in -- Now make a case alternative out of each group - mappM (match_con vars) eqn_groups `thenDs` \ alts -> - - returnDs (mkCoAlgCaseMatchResult var alts) + mappM (match_con vars ty) groups' `thenDs` \ alts -> + returnDs (adjustMatchResult (foldr (.) idWrapper wraps) $ + mkCoAlgCaseMatchResult var ty 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. +Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the +list comprehension in @matchClause@ (SLPJ, p.~94) does, except things +are trickier in real 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@. \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 selectMatchVar arg_pats `thenDs` \ arg_vars -> - - -- Now do the business to make the alt for _this_ ConPat ... - 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') +match_con vars ty eqns + = do { -- Make new vars for the con arguments; avoid new locals where possible + arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys + ; eqns' <- mapM shift eqns + ; match_result <- match (arg_vars ++ vars) ty eqns' + ; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) } where - shift_con_pat :: EquationInfo -> EquationInfo - shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result) - = EqnInfo n ctx (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. + ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns) + + shift eqn@(EqnInfo { eqn_wrap = wrap, + eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats }) + = do { prs <- dsHsNestedBinds bind + ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkDsLet (Rec prs), + eqn_pats = map unLoc arg_pats ++ pats }) } + + -- Get the arg types, which we use to type the new vars + -- to match on, from the "outside"; the types of pats1 may + -- be more refined, and hence won't do + arg_tys = substTys (zipTopTvSubst (dataConTyVars con) inst_tys) + (dataConOrigArgTys con) + inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque! + | otherwise = mkTyVarTys tvs1 \end{code} -Note on @shift_con_pats@ just above: does what the list comprehension in -@matchClause@ (SLPJ, p.~94) does, except things are trickier in real -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 -~~~~~~~~~~~~~~~~~~~~~~~ +Note [Existentials in shift_con_pat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = forall a. Ord a => T a (a->Int) @@ -154,7 +151,7 @@ Consider 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... + f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... After desugaring etc we'll get a single case: @@ -166,12 +163,11 @@ After desugaring etc we'll get a single case: False -> ...expr2... *** We have to substitute [a/b, d/e] in expr2! ** -That is what do_subst is doing. +Hence + False -> ....((/\b\(e:Ord b).expr2) a d).... 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. -