X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FCheck.lhs;h=9aac5ce777c04309f4d34bfc7982b5544c3a0bc8;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=ae190e402ec1c1b2684f26e31bc5ff2d20f9652a;hpb=6a15e98b0bcb45982822fe6c8fae620f329c3ccd;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index ae190e4..9aac5ce 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -11,14 +11,15 @@ module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( hsPatType, mkVanillaTuplePat ) import TcType ( tcTyConAppTyCon ) import DsUtils ( EquationInfo(..), MatchResult(..), CanItFail(..), firstPat ) import MatchLit ( tidyLitPat, tidyNPat ) import Id ( Id, idType ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels ) -import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc ) +import Name ( Name, mkInternalName, getOccName, isDataSymOcc, + getName, mkVarOccFS ) import TysWiredIn import PrelNames ( unboundKey ) import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) @@ -144,9 +145,9 @@ untidy b (L loc p) = L loc (untidy' b p) untidy' _ p@(ConPatIn name (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty - untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed + untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" - untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" + untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) @@ -189,19 +190,26 @@ There are several cases: \begin{code} -check' :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) +check' :: [(EqnNo, EquationInfo)] + -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all + EqnSet) -- Eqns that are used (others are overlapped) + check' [] = ([([],[])],emptyUniqSet) -check' [(n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _ })] - | all_vars ps = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n) +check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) + | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False } + = ([], unitUniqSet n) -- One eqn, which can't fail + + | first_eqn_all_vars && null rs -- One eqn, but it can fail + = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n) -check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _}) : rs) - | all_vars ps = (pats, addOneToUniqSet indexs n) + | first_eqn_all_vars -- Several eqns, first can fail + = (pats, addOneToUniqSet indexs n) where + first_eqn_all_vars = all_vars ps (pats,indexs) = check' rs -check' qs@((n, EqnInfo { eqn_pats = ps }) : _) - | all_vars ps = ([], unitUniqSet n) +check' qs | literals = split_by_literals qs | constructors = split_by_constructor qs | only_vars = first_column_only_vars qs @@ -375,7 +383,7 @@ make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) new_var = hash_x hash_x = mkInternalName unboundKey {- doesn't matter much -} - (mkVarOcc FSLIT("#x")) + (mkVarOccFS FSLIT("#x")) noSrcLoc make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] @@ -549,9 +557,9 @@ make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) where q = unLoc lq -make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) _) (ps, constraints) - | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) - | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) +make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) | otherwise = (nlConPat name pats_con : rest_pats, constraints) where name = getName id @@ -580,7 +588,32 @@ constraints. \begin{code} simplify_eqn :: EquationInfo -> EquationInfo -simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn) } +simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn), + eqn_rhs = simplify_rhs (eqn_rhs eqn) } + where + -- Horrible hack. The simplify_pat stuff converts NPlusK pats to WildPats + -- which of course loses the info that they can fail to match. So we + -- stick in a CanFail as if it were a guard. + -- The Right Thing to do is for the whole system to treat NPlusK pats properly + simplify_rhs (MatchResult can_fail body) + | any has_nplusk_pat (eqn_pats eqn) = MatchResult CanFail body + | otherwise = MatchResult can_fail body + +has_nplusk_lpat :: LPat Id -> Bool +has_nplusk_lpat (L _ p) = has_nplusk_pat p + +has_nplusk_pat :: Pat Id -> Bool +has_nplusk_pat (NPlusKPat _ _ _ _) = True +has_nplusk_pat (ParPat p) = has_nplusk_lpat p +has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p +has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p +has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps) +has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps +has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps +has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps +has_nplusk_pat (LazyPat p) = False -- Why? +has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think +has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat simplify_lpat :: LPat Id -> LPat Id simplify_lpat p = fmap simplify_pat p @@ -591,6 +624,7 @@ simplify_pat (VarPat id) = WildPat (idType id) simplify_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings simplify_pat (ParPat p) = unLoc (simplify_lpat p) simplify_pat (LazyPat p) = unLoc (simplify_lpat p) +simplify_pat (BangPat p) = unLoc (simplify_lpat p) simplify_pat (AsPat id p) = unLoc (simplify_lpat p) simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right @@ -611,10 +645,10 @@ simplify_pat (PArrPat ps ty) (PrefixCon (map simplify_lpat ps)) (mkPArrTy ty) -simplify_pat (TuplePat ps boxity) +simplify_pat (TuplePat ps boxity ty) = mk_simple_con_pat (tupleCon boxity arity) (PrefixCon (map simplify_lpat ps)) - (mkTupleTy boxity arity (map hsPatType ps)) + ty where arity = length ps @@ -635,9 +669,9 @@ simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2) simplify_pat (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat [] Boxed) + 0 -> simplify_pat (TuplePat [] Boxed unitTy) 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (TuplePat (map noLoc dict_and_method_pats) Boxed) + _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods)