From: Twan van Laarhoven Date: Thu, 17 Jan 2008 17:33:36 +0000 (+0000) Subject: Monadify deSugar/Match: use do, return, applicative, standard monad functions X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=121f13ea513421a40daf5c9fcdc684b42ea9acad Monadify deSugar/Match: use do, return, applicative, standard monad functions --- diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 3f3a127..6a74a69 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -60,20 +60,20 @@ matchCheck :: DsMatchContext -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchCheck ctx vars ty qs - = getDOptsDs `thenDs` \ dflags -> - matchCheck_really dflags ctx vars ty qs +matchCheck ctx vars ty qs = do + dflags <- getDOptsDs + matchCheck_really dflags ctx vars ty qs matchCheck_really dflags ctx vars ty qs - | incomplete && shadow = - dsShadowWarn ctx eqns_shadow `thenDs` \ () -> - dsIncompleteWarn ctx pats `thenDs` \ () -> + | incomplete && shadow = do + dsShadowWarn ctx eqns_shadow + dsIncompleteWarn ctx pats match vars ty qs - | incomplete = - dsIncompleteWarn ctx pats `thenDs` \ () -> + | incomplete = do + dsIncompleteWarn ctx pats match vars ty qs - | shadow = - dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + | shadow = do + dsShadowWarn ctx eqns_shadow match vars ty qs | otherwise = match vars ty qs @@ -263,7 +263,7 @@ match :: [Id] -- Variables rep'ing the exprs we're matching with match [] ty eqns = ASSERT2( not (null eqns), ppr ty ) - returnDs (foldr1 combineMatchResults match_results) + return (foldr1 combineMatchResults match_results) where match_results = [ ASSERT( null (eqn_pats eqn) ) eqn_rhs eqn @@ -280,7 +280,7 @@ match vars@(v:_) ty eqns ; let grouped = (groupEquations tidy_eqns) -- print the view patterns that are commoned up to help debug - ; ifOptDs Opt_D_dump_view_pattern_commoning (debug grouped) + ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped) ; match_results <- mapM match_group grouped ; return (adjustMatchResult (foldr1 (.) aux_binds) $ @@ -372,7 +372,7 @@ which will be scrutinised. This means: Replace variable patterns @x@ (@x /= v@) with the pattern @_@, together with the binding @x = v@. \item -Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. +Replace the `as' pattern @xp@ with the pattern p and a binding @x = do v@. \item Removing lazy (irrefutable) patterns (you don't want to know...). \item @@ -416,9 +416,9 @@ tidyEqnInfo :: Id -> EquationInfo -- NPlusKPat -- but no other -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) - = tidy1 v pat `thenDs` \ (wrap, pat') -> - returnDs (wrap, eqn { eqn_pats = pat' : pats }) +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do + (wrap, pat') <- tidy1 v pat + return (wrap, eqn { eqn_pats = do pat' : pats }) tidy1 :: Id -- The Id being scrutinised -> Pat Id -- The pattern against which it is to be matched @@ -438,12 +438,12 @@ tidy1 :: Id -- The Id being scrutinised tidy1 v (ParPat pat) = tidy1 v (unLoc pat) tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 v (WildPat ty) = returnDs (idDsWrapper, WildPat ty) +tidy1 v (WildPat ty) = return (idDsWrapper, WildPat ty) -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } tidy1 v (VarPat var) - = returnDs (wrapBind var v, WildPat (idType var)) + = return (wrapBind var v, WildPat (idType var)) tidy1 v (VarPatOut var binds) = do { prs <- dsLHsBinds binds @@ -470,10 +470,10 @@ tidy1 v (AsPat (L _ var) pat) tidy1 v (LazyPat pat) = do { sel_prs <- mkSelectorBinds pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; returnDs (mkDsLets sel_binds, WildPat (idType v)) } + ; return (mkDsLets sel_binds, WildPat (idType v)) } tidy1 v (ListPat pats ty) - = returnDs (idDsWrapper, unLoc list_ConPat) + = return (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) @@ -483,29 +483,29 @@ tidy1 v (ListPat pats ty) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern tidy1 v (PArrPat pats ty) - = returnDs (idDsWrapper, unLoc parrConPat) + = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) tidy1 v (TuplePat pats boxity ty) - = returnDs (idDsWrapper, unLoc tuple_ConPat) + = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 v (LitPat lit) - = returnDs (idDsWrapper, tidyLitPat lit) + = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form tidy1 v (NPat lit mb_neg eq) - = returnDs (idDsWrapper, tidyNPat lit mb_neg eq) + = return (idDsWrapper, tidyNPat lit mb_neg eq) -- Everything else goes through unchanged... tidy1 v non_interesting_pat - = returnDs (idDsWrapper, non_interesting_pat) + = return (idDsWrapper, non_interesting_pat) \end{code} \noindent @@ -702,34 +702,32 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr -matchSimply scrut hs_ctx pat result_expr fail_expr - = let +matchSimply scrut hs_ctx pat result_expr fail_expr = do + let match_result = cantFailMatchResult result_expr - rhs_ty = exprType fail_expr - -- Use exprType of fail_expr, because won't refine in the case of failure! - in - matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' -> + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + 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 -matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result - = getDOptsDs `thenDs` \ dflags -> - getSrcSpanDs `thenDs` \ locn -> +matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do + dflags <- getDOptsDs + locn <- getSrcSpanDs let - match_fn dflags + match_fn dflags | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx - | otherwise = match - where - ds_ctx = DsMatchContext hs_ctx locn - in + | otherwise = match + where + ds_ctx = DsMatchContext hs_ctx locn match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] -matchSinglePat scrut hs_ctx pat ty match_result - = selectSimpleMatchVarL pat `thenDs` \ var -> - matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' -> - returnDs (adjustMatchResult (bindNonRec var scrut) 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}