X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FCheck.lhs;h=9aac5ce777c04309f4d34bfc7982b5544c3a0bc8;hb=960a5e6a6f604aa01f5f74b80fb0f61ceffd7ed3;hp=309aab2f50a574768615873f36051021d87bdee2;hpb=dd6490c2a4e5eadb5cda4f8c938d69e05d6946d6;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 309aab2..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) @@ -382,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] @@ -556,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 @@ -608,9 +609,10 @@ 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 (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 (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 @@ -622,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 @@ -642,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 @@ -666,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)