X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=5c6b2244661b20aa50fa7003e8b86287c6c171cd;hb=e01036f89a0d3949ea642dd42b29bc8e31658f0f;hp=0544d9bb18fe89e26dc5887fc358d277a997b8ea;hpb=e6e40cc112504af5062afed162993aa9352c1d2c;p=ghc-hetmet.git diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 0544d9b..5c6b224 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -38,6 +38,7 @@ import Name import Outputable import FastString +import Control.Monad( when ) import qualified Data.Map as Map \end{code} @@ -55,9 +56,9 @@ matchCheck :: DsMatchContext -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchCheck ctx vars ty qs = do - dflags <- getDOptsDs - matchCheck_really dflags ctx vars ty qs +matchCheck ctx vars ty qs + = do { dflags <- getDOptsDs + ; matchCheck_really dflags ctx vars ty qs } matchCheck_really :: DynFlags -> DsMatchContext @@ -65,28 +66,31 @@ matchCheck_really :: DynFlags -> Type -> [EquationInfo] -> DsM MatchResult -matchCheck_really dflags ctx vars ty qs - | incomplete && shadow = do - dsShadowWarn ctx eqns_shadow - dsIncompleteWarn ctx pats - match vars ty qs - | incomplete = do - dsIncompleteWarn ctx pats - match vars ty qs - | shadow = do - dsShadowWarn ctx eqns_shadow - match vars ty qs - | otherwise = - match vars ty qs - where (pats, eqns_shadow) = check qs - incomplete = want_incomplete && (notNull pats) - want_incomplete = case ctx of - DsMatchContext RecUpd _ -> - dopt Opt_WarnIncompletePatternsRecUpd dflags - _ -> - dopt Opt_WarnIncompletePatterns dflags - shadow = dopt Opt_WarnOverlappingPatterns dflags - && not (null eqns_shadow) +matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs + = do { when shadow (dsShadowWarn ctx eqns_shadow) + ; when incomplete (dsIncompleteWarn ctx pats) + ; match vars ty qs } + where + (pats, eqns_shadow) = check qs + incomplete = incomplete_flag hs_ctx && (notNull pats) + shadow = dopt Opt_WarnOverlappingPatterns dflags + && notNull eqns_shadow + + incomplete_flag :: HsMatchContext id -> Bool + incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags + + incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags + + incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags + + incomplete_flag ThPatQuote = False + incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns + -- in list comprehensions, pattern guards + -- etc. They are often *supposed* to be + -- incomplete \end{code} This variable shows the maximum number of lines of output generated for warnings. @@ -280,13 +284,13 @@ match vars@(v:_) ty eqns = ASSERT( not (null eqns ) ) do { -- Tidy the first pattern, generating -- auxiliary bindings if necessary - (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - ; let grouped = groupEquations tidy_eqns + ; let grouped = groupEquations tidy_eqns -- print the view patterns that are commoned up to help debug - ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) + ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) ; match_results <- mapM match_group grouped ; return (adjustMatchResult (foldr1 (.) aux_binds) $ @@ -331,7 +335,8 @@ matchVariables [] _ _ = panic "matchVariables" matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchBangs (var:vars) ty eqns - = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns) + = do { match_result <- match (var:vars) ty $ + map (decomposeFirstPat getBangPat) eqns ; return (mkEvalMatchResult var ty match_result) } matchBangs [] _ _ = panic "matchBangs" @@ -340,7 +345,8 @@ matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 ; var' <- newUniqueId var (hsPatType pat) - ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getCoPat) eqns ; co' <- dsHsWrapper co ; let rhs' = co' (Var var) ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } @@ -355,7 +361,8 @@ matchView (var:vars) ty (eqns@(eqn1:_)) let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 -- do the rest of the compilation ; var' <- newUniqueId var (hsPatType pat) - ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getViewPat) eqns -- compile the view expressions ; viewExpr' <- dsLExpr viewExpr ; return (mkViewMatchResult var' viewExpr' var match_result) } @@ -367,12 +374,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo - -decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat) -decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat) -decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat) - +getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id +getCoPat (CoPat _ pat _) = pat +getCoPat _ = panic "getCoPat" +getBangPat (BangPat pat ) = unLoc pat +getBangPat _ = panic "getBangPat" +getViewPat (ViewPat _ pat _) = unLoc pat +getViewPat _ = panic "getBangPat" \end{code} %************************************************************************ @@ -464,11 +472,6 @@ tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) tidy1 v (VarPat var) = return (wrapBind var v, WildPat (idType var)) -tidy1 v (VarPatOut var binds) - = do { ds_ev_binds <- dsTcEvBinds binds - ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds, - WildPat (idType var)) } - -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } tidy1 v (AsPat (L _ var) pat) @@ -526,7 +529,6 @@ tidy1 _ (NPat lit mb_neg eq) tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p) tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p) tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p) -tidy1 _ p@(BangPat (L _(VarPatOut _ _))) = return (idDsWrapper, p) tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p) tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p) tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p) @@ -737,19 +739,21 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr - matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult -- Do not warn about incomplete patterns -- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine -matchSinglePat (Var var) _ (L _ pat) ty match_result - = match [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] - -matchSinglePat scrut hs_ctx pat ty match_result = do - var <- selectSimpleMatchVarL pat - match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result - return (adjustMatchResult (bindNonRec var scrut) match_result') +matchSinglePat (Var var) ctx (L _ pat) ty match_result + = do { locn <- getSrcSpanDs + ; matchCheck (DsMatchContext ctx locn) + [var] ty + [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] } + +matchSinglePat scrut hs_ctx pat ty match_result + = do { var <- selectSimpleMatchVarL pat + ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result + ; return (adjustMatchResult (bindNonRec var scrut) match_result') } \end{code} @@ -882,7 +886,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 lexp e1 e1' && lexp e2 e2' exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = eq_list tup_arg es1 es2 - exp (HsIf e e1 e2) (HsIf e' e1' e2') = + exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions