X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FCheck.lhs;h=693368bc53bdb2ab35ea15fefcda22aadcd2b10b;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=1e4a18684581f3617b7645c9b42a5ac4e3f8f5fb;hpb=a3e01707ebc2e7180840b5ab3534f818b43c2873;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 1e4a186..693368b 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] @@ -411,11 +419,21 @@ get_used_lits qs = remove_dups' all_literals get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit] get_used_lits' [] = [] get_used_lits' (q:qs) - | LitPat lit <- first_pat = lit : get_used_lits qs - | NPatOut lit _ _ <- first_pat = lit : get_used_lits qs - | otherwise = get_used_lits qs - where - first_pat = firstPatN q + | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs + | otherwise = get_used_lits qs + +get_lit :: Pat id -> Maybe HsLit +-- Get a representative HsLit to stand for the OverLit +-- It doesn't matter which one, because they will only be compared +-- with other HsLits gotten in the same way +get_lit (LitPat lit) = Just lit +get_lit (NPat (HsIntegral i _) mb _ _) = Just (HsIntPrim (mb_neg mb i)) +get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f)) +get_lit other_pat = Nothing + +mb_neg :: Num a => Maybe b -> a -> a +mb_neg Nothing v = v +mb_neg (Just _) v = -v get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = unused_cons @@ -462,7 +480,7 @@ is_con _ = False is_lit :: Pat Id -> Bool is_lit (LitPat _) = True -is_lit (NPatOut _ _ _) = True +is_lit (NPat _ _ _ _) = True is_lit _ = False is_var :: Pat Id -> Bool @@ -475,10 +493,10 @@ is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True is_var_con con _ = False is_var_lit :: HsLit -> Pat Id -> Bool -is_var_lit lit (WildPat _) = True -is_var_lit lit (LitPat lit') | lit == lit' = True -is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True -is_var_lit lit _ = False +is_var_lit lit (WildPat _) = True +is_var_lit lit pat + | Just lit' <- get_lit pat = lit == lit' + | otherwise = False \end{code} The difference beteewn @make_con@ and @make_whole_con@ is that @@ -539,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 @@ -550,7 +568,7 @@ make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) _) (ps, constraints) -- reconstruct parallel array pattern -- --- * don't check for the type only; we need to make sure that we are really +-- * don't check for the type only; we need to make sure that we are really -- dealing with one of the fake constructors and not with the real -- representation @@ -570,7 +588,31 @@ 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 +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 @@ -601,33 +643,33 @@ 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 -simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat)) - -- unpack string patterns fully, so we can see when they overlap with -- each other, or even explicit lists of Chars. -simplify_pat pat@(NPatOut (HsString s) _ _) = +simplify_pat pat@(LitPat (HsString s)) = foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy) (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s) where mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy) -simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat)) +simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat)) + +simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)) -simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2) +simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2) = WildPat (idType (unLoc id)) 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)