Commit ec8a6628 authored by twanvl's avatar twanvl
Browse files

Monadify rename/RnTypes: use do, return and standard monad functions

parent 37e2b6d8
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment