lookupLocatedOccRn, lookupLocatedBndrRn,
lookupLocatedGlobalOccRn, bindTyVarsRn,
lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
- lookupRecordBndr, mapFvRn, warnUnusedMatches,
+ lookupRecordBndr, mapFvRn,
newIPNameRn, bindPatSigTyVarsFV)
import TcRnMonad
import RdrName
\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,
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
-- 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 $
; 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}
-- 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}
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)
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}
-- (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
---------------------------
-- (- 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
---------------------------
-- 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
= 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
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
-- (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
-- 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])
--------------------------------------
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
-- 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
-- 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 &&
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
= 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)
projects / ghc-hetmet.git / blobdiff