X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatchCon.lhs;h=c7e2b938202a13c932fa21a3a029b3b1d2d9e337;hb=a3e01707ebc2e7180840b5ab3534f818b43c2873;hp=d572e60f3278b8dc44490c2c3a67b38ac559621a;hpb=01bb2208d997bd68f7f8229d7464b253bc8519c7;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index d572e60..c7e2b93 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -1,28 +1,30 @@ -% -% (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 HsSyn ( OutPat(..), HsLit, HsExpr ) -import DsHsSyn ( outPatType ) +import {-# SOURCE #-} Match ( match ) +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 ( GenId{-instances-}, SYN_IE(Id) ) -import Util ( panic, assertPanic ) +import Id ( Id ) +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 @@ -77,65 +79,91 @@ have-we-used-all-the-constructors? question; the local function @match_cons_used@ does all the real work. \begin{code} matchConFamily :: [Id] + -> Type -> [EquationInfo] - -> [EquationInfo] -- Shadows -> DsM MatchResult - -matchConFamily (var:vars) eqns_info shadows - = match_cons_used vars eqns_info shadows `thenDs` \ alts -> - mkCoAlgCaseMatchResult var alts +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 { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con + in + -- Now make a case alternative out of each group + mappM (match_con vars ty) eqn_groups `thenDs` \ alts -> + returnDs (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_cons_used _ [{- no more eqns -}] _ = returnDs [] +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 -match_cons_used vars eqns_info@(EqnInfo (ConPat data_con _ arg_pats : ps1) _ : eqns) shadows - = let - (eqns_for_this_con, eqns_not_for_this_con) = splitByCon eqns_info - (shadows_for_this_con, shadows_not_for_this_con) = splitByCon shadows - 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 shadows_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 -> - - -- Now do the business to make the alt for _this_ ConPat ... - match (new_vars++vars) - (map shift_con_pat eqns_for_this_con) - (map shift_con_pat shadows_for_this_con) `thenDs` \ match_result -> - - returnDs ( - (data_con, new_vars, match_result) - : rest_of_alts - ) + ; match_result <- match (arg_vars ++ vars) ty (shiftEqns eqns) + + ; binds <- mapM ds_binds [ bind | ConPatOut _ _ _ bind _ _ <- pats, + not (isEmptyLHsBinds bind) ] + + ; let match_result' = bindInMatchResult (line_up other_pats) $ + mkCoLetsMatchResult binds match_result + + ; return (data_con, tvs1 ++ dicts1 ++ 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) - WildPat _ -> (info:rest_yes, info:rest_no) - -- WildPats will be in the shadows only, - -- and they go into both groups - other_pat -> (rest_yes, info:rest_no) - where - (rest_yes, rest_no) = splitByCon rest - - shift_con_pat :: EquationInfo -> EquationInfo - shift_con_pat (EqnInfo (ConPat _ _ pats': pats) match_result) - = EqnInfo (pats' ++ pats) match_result - shift_con_pat (EqnInfo (WildPat _: pats) match_result) -- Will only happen in shadow - = EqnInfo ([WildPat (outPatType arg_pat) | arg_pat <- arg_pats] ++ pats) match_result - shift_con_pat other = panic "matchConFamily:match_cons_used:shift_con_pat" + pats@(pat1 : other_pats) = map firstPat eqns + ConPatOut (L _ data_con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = pat1 + + ds_binds bind = do { prs <- dsHsNestedBinds bind; return (Rec prs) } + + line_up pats + | null tvs1 && null dicts1 = [] -- Common case + | otherwise = [ pr | ConPatOut _ ts ds _ _ _ <- pats, + pr <- (ts `zip` tvs1) ++ (ds `zip` dicts1)] + + -- 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 data_con) inst_tys) + (dataConOrigArgTys data_con) + inst_tys | isVanillaDataCon data_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@. +Note [Existentials in shift_con_pat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 b) (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! ** +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. +