From ec8a6628b5f58655990bd07bad791079ed04e8b8 Mon Sep 17 00:00:00 2001 From: Twan van Laarhoven Date: Thu, 17 Jan 2008 19:08:23 +0000 Subject: [PATCH] Monadify rename/RnTypes: use do, return and standard monad functions --- compiler/rename/RnTypes.lhs | 190 +++++++++++++++++++++---------------------- 1 file changed, 95 insertions(+), 95 deletions(-) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 76384ab..dd1851d 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -66,9 +66,9 @@ to break several loop. \begin{code} rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnHsTypeFVs doc_str ty - = rnLHsType doc_str ty `thenM` \ ty' -> - returnM (ty', extractHsTyNames ty') +rnHsTypeFVs doc_str ty = do + ty' <- rnLHsType doc_str ty + return (ty', extractHsTyNames ty') rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -- rnHsSigType is used for source-language type signatures, @@ -86,11 +86,11 @@ rnLHsType doc = wrapLocM (rnHsType doc) rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name) -rnHsType doc (HsForAllTy Implicit _ ctxt ty) +rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} - = getLocalRdrEnv `thenM` \ name_env -> + name_env <- getLocalRdrEnv let mentioned = extractHsRhoRdrTyVars ctxt ty @@ -100,26 +100,26 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) -- class C a where { op :: a -> a } forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned tyvar_bndrs = userHsTyVarBndrs forall_tyvars - in + rnForAll doc Implicit tyvar_bndrs ctxt ty -rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) +rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not - = let + let mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau) forall_tyvar_names = hsLTyVarLocNames forall_tyvars -- Explicitly quantified but not mentioned in ctxt or tau warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names - in - mappM_ (forAllWarn doc tau) warn_guys `thenM_` + + mapM_ (forAllWarn doc tau) warn_guys rnForAll doc Explicit forall_tyvars ctxt tau -rnHsType doc (HsTyVar tyvar) - = lookupOccRn tyvar `thenM` \ tyvar' -> - returnM (HsTyVar tyvar') +rnHsType doc (HsTyVar tyvar) = do + tyvar' <- lookupOccRn tyvar + return (HsTyVar tyvar') rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) = setSrcSpan loc $ @@ -132,68 +132,68 @@ rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) ; ty2' <- rnLHsType doc ty2 ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' } -rnHsType doc (HsParTy ty) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsParTy ty') +rnHsType doc (HsParTy ty) = do + ty' <- rnLHsType doc ty + return (HsParTy ty') -rnHsType doc (HsBangTy b ty) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsBangTy b ty') +rnHsType doc (HsBangTy b ty) = do + ty' <- rnLHsType doc ty + return (HsBangTy b ty') rnHsType doc (HsNumTy i) - | i == 1 = returnM (HsNumTy i) - | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i) + | i == 1 = return (HsNumTy i) + | otherwise = addErr err_msg >> return (HsNumTy i) where err_msg = ptext SLIT("Only unit numeric type pattern is valid") -rnHsType doc (HsFunTy ty1 ty2) - = rnLHsType doc ty1 `thenM` \ ty1' -> +rnHsType doc (HsFunTy ty1 ty2) = do + ty1' <- rnLHsType doc ty1 -- Might find a for-all as the arg of a function type - rnLHsType doc ty2 `thenM` \ ty2' -> + ty2' <- rnLHsType doc ty2 -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2' -rnHsType doc (HsListTy ty) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsListTy ty') +rnHsType doc (HsListTy ty) = do + ty' <- rnLHsType doc ty + return (HsListTy ty') -rnHsType doc (HsKindSig ty k) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsKindSig ty' k) +rnHsType doc (HsKindSig ty k) = do + ty' <- rnLHsType doc ty + return (HsKindSig ty' k) -rnHsType doc (HsPArrTy ty) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsPArrTy ty') +rnHsType doc (HsPArrTy ty) = do + ty' <- rnLHsType doc ty + return (HsPArrTy ty') -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (HsTupleTy tup_con tys) - = mappM (rnLHsType doc) tys `thenM` \ tys' -> - returnM (HsTupleTy tup_con tys') +rnHsType doc (HsTupleTy tup_con tys) = do + tys' <- mapM (rnLHsType doc) tys + return (HsTupleTy tup_con tys') -rnHsType doc (HsAppTy ty1 ty2) - = rnLHsType doc ty1 `thenM` \ ty1' -> - rnLHsType doc ty2 `thenM` \ ty2' -> - returnM (HsAppTy ty1' ty2') +rnHsType doc (HsAppTy ty1 ty2) = do + ty1' <- rnLHsType doc ty1 + ty2' <- rnLHsType doc ty2 + return (HsAppTy ty1' ty2') -rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenM` \ pred' -> - returnM (HsPredTy pred') +rnHsType doc (HsPredTy pred) = do + pred' <- rnPred doc pred + return (HsPredTy pred') -rnHsType doc (HsSpliceTy _) - = do { addErr (ptext SLIT("Type splices are not yet implemented")) - ; failM } +rnHsType doc (HsSpliceTy _) = do + addErr (ptext SLIT("Type splices are not yet implemented")) + failM -rnHsType doc (HsDocTy ty haddock_doc) - = rnLHsType doc ty `thenM` \ ty' -> - rnLHsDoc haddock_doc `thenM` \ haddock_doc' -> - returnM (HsDocTy ty' haddock_doc') +rnHsType doc (HsDocTy ty haddock_doc) = do + ty' <- rnLHsType doc ty + haddock_doc' <- rnLHsDoc haddock_doc + return (HsDocTy ty' haddock_doc') -rnLHsTypes doc tys = mappM (rnLHsType doc) tys +rnLHsTypes doc tys = mapM (rnLHsType doc) tys \end{code} @@ -211,10 +211,10 @@ rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> - rnContext doc ctxt `thenM` \ new_ctxt -> - rnLHsType doc ty `thenM` \ new_ty -> - returnM (HsForAllTy exp new_tyvars new_ctxt new_ty) + = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do + new_ctxt <- rnContext doc ctxt + new_ty <- rnLHsType doc ty + return (HsForAllTy exp new_tyvars new_ctxt new_ty) -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly \end{code} @@ -230,7 +230,7 @@ rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) rnContext doc = wrapLocM (rnContext' doc) rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mappM (rnLPred doc) ctxt +rnContext' doc ctxt = mapM (rnLPred doc) ctxt rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) rnLPred doc = wrapLocM (rnPred doc) @@ -238,17 +238,17 @@ rnLPred doc = wrapLocM (rnPred doc) rnPred doc (HsClassP clas tys) = do { clas_name <- lookupOccRn clas ; tys' <- rnLHsTypes doc tys - ; returnM (HsClassP clas_name tys') + ; return (HsClassP clas_name tys') } rnPred doc (HsEqualP ty1 ty2) = do { ty1' <- rnLHsType doc ty1 ; ty2' <- rnLHsType doc ty2 - ; returnM (HsEqualP ty1' ty2') + ; return (HsEqualP ty1' ty2') } rnPred doc (HsIParam n ty) = do { name <- newIPNameRn n ; ty' <- rnLHsType doc ty - ; returnM (HsIParam name ty') + ; return (HsIParam name ty') } \end{code} @@ -325,13 +325,13 @@ mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 - | nofix_error - = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (OpApp e1 op2 fix2 e2) + | nofix_error = do + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) + return (OpApp e1 op2 fix2 e2) - | associate_right - = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> - returnM (OpApp e11 op1 fix1 (L loc' new_e)) + | associate_right = do + new_e <- mkOpAppRn e12 op2 fix2 e2 + return (OpApp e11 op1 fix1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -339,13 +339,13 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 --------------------------- -- (- neg_arg) `op` e2 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 - | nofix_error - = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` - returnM (OpApp e1 op2 fix2 e2) + | nofix_error = do + addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) + return (OpApp e1 op2 fix2 e2) - | associate_right - = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> - returnM (NegApp (L loc' new_e) neg_name) + | associate_right = do + new_e <- mkOpAppRn neg_arg op2 fix2 e2 + return (NegApp (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 @@ -353,9 +353,9 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 --------------------------- -- e1 `op` - neg_arg mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` - returnM (OpApp e1 op1 fix1 e2) + | not associate_right= do -- We *want* right association + addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) + return (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -365,7 +365,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - returnM (OpApp e1 op fix e2) + return (OpApp e1 op fix e2) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -382,7 +382,7 @@ right_op_ok fix1 other mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) mkNegAppRn neg_arg neg_name = ASSERT( not_op_app (unLoc neg_arg) ) - returnM (NegApp neg_arg neg_name) + return (NegApp neg_arg neg_name) not_op_app (OpApp _ _ _ _) = False not_op_app other = True @@ -396,13 +396,13 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged -- (e11 `op1` e12) `op2` e2 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) op2 fix2 a2 - | nofix_error - = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (HsArrForm op2 (Just fix2) [a1, a2]) + | nofix_error = do + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) + return (HsArrForm op2 (Just fix2) [a1, a2]) - | associate_right - = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> - returnM (HsArrForm op1 (Just fix1) + | associate_right = do + new_c <- mkOpFormRn a12 op2 fix2 a2 + return (HsArrForm op1 (Just fix1) [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) -- TODO: locs are wrong where @@ -410,7 +410,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _ -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = returnM (HsArrForm op (Just fix) [arg1, arg2]) + = return (HsArrForm op (Just fix) [arg1, arg2]) -------------------------------------- @@ -432,7 +432,7 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat (unLoc p2) ) - returnM (ConPatIn op (InfixCon p1 p2)) + return (ConPatIn op (InfixCon p1 p2)) not_op_pat (ConPatIn _ (InfixCon _ _)) = False not_op_pat other = True @@ -443,13 +443,13 @@ checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM () -- See comments with rnExpr (OpApp ...) about "deriving" checkPrecMatch False fn match - = returnM () + = return () checkPrecMatch True op (MatchGroup ms _) = mapM_ check ms where check (L _ (Match (p1:p2:_) _ _)) - = checkPrec op (unLoc p1) False `thenM_` - checkPrec op (unLoc p2) True + = do checkPrec op (unLoc p1) False + checkPrec op (unLoc p2) True check _ = return () -- This can happen. Consider @@ -460,9 +460,9 @@ checkPrecMatch True op (MatchGroup ms _) -- until the type checker). So we don't want to crash on the -- second eqn. -checkPrec op (ConPatIn op1 (InfixCon _ _)) right - = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> +checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do + op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1) let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -472,11 +472,11 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right info = (ppr_op op, op_fix) info1 = (ppr_op op1, op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) - in + checkErr inf_ok (precParseErr infol infor) checkPrec op pat right - = returnM () + = return () -- Check precedence of (arg op) or (op arg) respectively -- If arg is itself an operator application, then either @@ -488,11 +488,11 @@ checkSectionPrec direction section op arg = case unLoc arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix NegApp _ _ -> go_for_it pp_prefix_minus negateFixity - other -> returnM () + other -> return () where L _ (HsVar op_name) = op - go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) - = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> + go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) = do + op_fix@(Fixity op_prec _) <- lookupFixityRn op_name checkErr (op_prec < arg_prec || op_prec == arg_prec && direction == assoc) (sectionPrecErr (ppr_op op_name, op_fix) -- 1.7.10.4