\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnTypes ( rnHsType, rnContext,
- rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs,
- rnPat, rnPats, rnPatsAndThen, -- Here because it's not part
- rnOverLit, litFVs, -- of any mutual recursion
- precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize
+module RnTypes (
+ -- Type related stuff
+ rnHsType, rnLHsType, rnLHsTypes, rnContext,
+ rnHsSigType, rnHsTypeFVs,
+
+ -- Patterns and literals
+ rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part
+ rnLit, rnOverLit, -- of any mutual recursion
+
+ -- Precence related stuff
+ mkOpAppRn, mkNegAppRn, mkOpFormRn,
+ checkPrecMatch, checkSectionPrec,
+
+ -- Error messages
+ dupFieldErr, patSigErr, checkTupSize
) where
-import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) )
+import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
import HsSyn
-import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNamePat,
- extractHsTyRdrTyVars, extractHsCtxtRdrTyVars )
-import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat,
- extractHsTyNames,
- parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name )
-import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn,
- newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn,
- bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches )
+import RdrHsSyn ( extractHsRhoRdrTyVars )
+import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name,
+ listTyCon_name
+ )
+import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
+ lookupLocatedOccRn, lookupLocatedBndrRn,
+ lookupLocatedGlobalOccRn, bindTyVarsRn,
+ lookupFixityRn, lookupTyFixityRn,
+ mapFvRn, warnUnusedMatches,
+ newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
import TcRnMonad
-
-import PrelNames( cCallishClassKeys, eqStringName, eqClassName, integralClassName,
- negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName,
- timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName )
+import RdrName ( RdrName, elemLocalRdrEnv )
+import PrelNames ( eqClassName, integralClassName, geName, eqName,
+ negateName, minusName, lengthPName, indexPName,
+ plusIntegerName, fromIntegerName, timesIntegerName,
+ ratioDataConName, fromRationalName )
+import TypeRep ( funTyCon )
import Constants ( mAX_TUPLE_SIZE )
-import TysWiredIn ( intTyCon )
-import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
- floatPrimTyCon, doublePrimTyCon )
-import RdrName ( elemRdrEnv )
-import Name ( Name, NamedThing(..) )
+import Name ( Name )
+import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
import NameSet
-import Unique ( Uniquable(..) )
import Literal ( inIntRange, inCharRange )
-import BasicTypes ( compareFixity, arrowFixity )
-import List ( nub )
-import ListSetOps ( removeDupsEq, removeDups )
+import BasicTypes ( compareFixity, funTyFixity, negateFixity,
+ Fixity(..), FixityDirection(..) )
+import ListSetOps ( removeDups )
import Outputable
#include "HsVersions.h"
%*********************************************************
\begin{code}
-rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars)
+rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnHsTypeFVs doc_str ty
- = rnHsType doc_str ty `thenM` \ ty' ->
- returnM (ty', extractHsTyNames ty')
-
-rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars)
-rnHsSigTypeFVs doc_str ty
- = rnHsSigType doc_str ty `thenM` \ ty' ->
+ = rnLHsType doc_str ty `thenM` \ ty' ->
returnM (ty', extractHsTyNames ty')
-rnHsSigType :: SDoc -> RdrNameHsType -> RnM RenamedHsType
+rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
- = rnHsType (text "In the type signature for" <+> doc_str) ty
+ = rnLHsType (text "In the type signature for" <+> doc_str) ty
\end{code}
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.
\begin{code}
-rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType
+rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsType doc = wrapLocM (rnHsType doc)
+
+rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
-rnHsType doc (HsForAllTy Nothing ctxt ty)
+rnHsType doc (HsForAllTy Implicit _ ctxt ty)
-- 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 ->
let
- mentioned_in_tau = extractHsTyRdrTyVars ty
- mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
- mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
+ mentioned = extractHsRhoRdrTyVars ctxt ty
-- Don't quantify over type variables that are in scope;
-- when GlasgowExts is off, there usually won't be any, except for
-- class signatures:
-- class C a where { op :: a -> a }
- forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned
+ forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
+ tyvar_bndrs = userHsTyVarBndrs forall_tyvars
in
- rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
+ rnForAll doc Implicit tyvar_bndrs ctxt ty
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
+rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
-- Explicit quantification.
-- Check that the forall'd tyvars are actually
-- mentioned in the type, and produce a warning if not
= let
- mentioned_in_tau = extractHsTyRdrTyVars tau
- mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
- mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
- forall_tyvar_names = hsTyVarNames forall_tyvars
+ 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) forall_tyvar_names
+ warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
in
mappM_ (forAllWarn doc tau) warn_guys `thenM_`
- rnForAll doc forall_tyvars ctxt tau
+ rnForAll doc Explicit forall_tyvars ctxt tau
rnHsType doc (HsTyVar tyvar)
= lookupOccRn tyvar `thenM` \ tyvar' ->
returnM (HsTyVar tyvar')
-rnHsType doc (HsOpTy ty1 op ty2)
- = (case op of
- HsArrow -> returnM HsArrow
- HsTyOp n -> lookupOccRn n `thenM` \ n' ->
- returnM (HsTyOp n')
- ) `thenM` \ op' ->
- rnHsType doc ty1 `thenM` \ ty1' ->
- rnHsType doc ty2 `thenM` \ ty2' ->
- lookupTyFixityRn op' `thenM` \ fix ->
- mkHsOpTyRn op' fix ty1' ty2'
+rnHsType doc (HsOpTy ty1 (L loc op) ty2)
+ = setSrcSpan loc (
+ lookupOccRn op `thenM` \ op' ->
+ let
+ l_op' = L loc op'
+ in
+ lookupTyFixityRn l_op' `thenM` \ fix ->
+ rnLHsType doc ty1 `thenM` \ ty1' ->
+ rnLHsType doc ty2 `thenM` \ ty2' ->
+ mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
+ )
rnHsType doc (HsParTy ty)
- = rnHsType doc ty `thenM` \ ty' ->
+ = rnLHsType doc ty `thenM` \ ty' ->
returnM (HsParTy ty')
+rnHsType doc (HsBangTy b ty)
+ = rnLHsType doc ty `thenM` \ ty' ->
+ returnM (HsBangTy b ty')
+
rnHsType doc (HsNumTy i)
| i == 1 = returnM (HsNumTy i)
| otherwise = addErr err_msg `thenM_` returnM (HsNumTy i)
rnHsType doc (HsFunTy ty1 ty2)
- = rnHsType doc ty1 `thenM` \ ty1' ->
+ = rnLHsType doc ty1 `thenM` \ ty1' ->
-- Might find a for-all as the arg of a function type
- rnHsType doc ty2 `thenM` \ ty2' ->
+ rnLHsType doc ty2 `thenM` \ ty2' ->
-- Or as the result. This happens when reading Prelude.hi
-- when we find return :: forall m. Monad m -> forall a. a -> m a
- returnM (HsFunTy ty1' ty2')
+
+ -- Check for fixity rearrangements
+ mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2'
rnHsType doc (HsListTy ty)
- = rnHsType doc ty `thenM` \ ty' ->
+ = rnLHsType doc ty `thenM` \ ty' ->
returnM (HsListTy ty')
rnHsType doc (HsKindSig ty k)
- = rnHsType doc ty `thenM` \ ty' ->
+ = rnLHsType doc ty `thenM` \ ty' ->
returnM (HsKindSig ty' k)
rnHsType doc (HsPArrTy ty)
- = rnHsType doc ty `thenM` \ ty' ->
+ = rnLHsType doc ty `thenM` \ ty' ->
returnM (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 (rnHsType doc) tys `thenM` \ tys' ->
+ = mappM (rnLHsType doc) tys `thenM` \ tys' ->
returnM (HsTupleTy tup_con tys')
rnHsType doc (HsAppTy ty1 ty2)
- = rnHsType doc ty1 `thenM` \ ty1' ->
- rnHsType doc ty2 `thenM` \ ty2' ->
+ = rnLHsType doc ty1 `thenM` \ ty1' ->
+ rnLHsType doc ty2 `thenM` \ ty2' ->
returnM (HsAppTy ty1' ty2')
rnHsType doc (HsPredTy pred)
= rnPred doc pred `thenM` \ pred' ->
returnM (HsPredTy pred')
-rnHsTypes doc tys = mappM (rnHsType doc) tys
+rnLHsTypes doc tys = mappM (rnLHsType doc) tys
\end{code}
\begin{code}
-rnForAll doc forall_tyvars ctxt ty
+rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
+ -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
+
+rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
+ -- One reason for this case is that a type like Int#
+ -- starts off as (HsForAllTy Nothing [] Int), in case
+ -- there is some quantification. Now that we have quantified
+ -- and discovered there are no type variables, it's nicer to turn
+ -- it into plain Int. If it were Int# instead of Int, we'd actually
+ -- get an error, because the body of a genuine for-all is
+ -- of kind *.
+
+rnForAll doc exp forall_tyvars ctxt ty
= bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
rnContext doc ctxt `thenM` \ new_ctxt ->
- rnHsType doc ty `thenM` \ new_ty ->
- returnM (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
+ rnLHsType doc ty `thenM` \ new_ty ->
+ returnM (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}
-%*********************************************************
-%* *
-\subsection{Fixities}
-%* *
-%*********************************************************
+%************************************************************************
+%* *
+ Fixities and precedence parsing
+%* *
+%************************************************************************
+@mkOpAppRn@ deals with operator fixities. The argument expressions
+are assumed to be already correctly arranged. It needs the fixities
+recorded in the OpApp nodes, because fixity info applies to the things
+the programmer actually wrote, so you can't find it out from the Name.
+
+Furthermore, the second argument is guaranteed not to be another
+operator application. Why? Because the parser parses all
+operator appications left-associatively, EXCEPT negation, which
+we need to handle specially.
Infix types are read in a *right-associative* way, so that
a `op` b `op` c
is always read in as
mkHsOpTyRn rearranges where necessary. The two arguments
have already been renamed and rearranged. It's made rather tiresome
-by the presence of ->
+by the presence of ->, which is a separate syntactic construct.
\begin{code}
-lookupTyFixityRn HsArrow = returnM arrowFixity
-lookupTyFixityRn (HsTyOp n)
- = doptM Opt_GlasgowExts `thenM` \ glaExts ->
- warnIf (not glaExts) (infixTyConWarn n) `thenM_`
- lookupFixityRn n
-
+---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
-mkHsOpTyRn :: HsTyOp Name -> Fixity
- -> RenamedHsType -> RenamedHsType
- -> RnM RenamedHsType
+mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
+ -> SDoc -> Fixity -> LHsType Name -> LHsType Name
+ -> RnM (HsType Name)
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
+ = do { fix2 <- lookupTyFixityRn op2
+ ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
+ (\t1 t2 -> HsOpTy t1 op2 t2)
+ (ppr op2) fix2 ty21 ty22 loc2 }
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22))
+ = mk_hs_op_ty mk1 pp_op1 fix1 ty1
+ HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2 -- Default case, no rearrangment
+ = return (mk1 ty1 ty2)
+
+---------------
+mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
+ -> SDoc -> Fixity -> LHsType Name
+ -> (LHsType Name -> LHsType Name -> HsType Name)
+ -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
+ -> RnM (HsType Name)
+mk_hs_op_ty mk1 pp_op1 fix1 ty1
+ mk2 pp_op2 fix2 ty21 ty22 loc2
+ | nofix_error = do { addErr (precParseErr (quotes pp_op1,fix1)
+ (quotes pp_op2,fix2))
+ ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
+ | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
+ | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
+ new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21
+ ; return (mk2 (noLoc new_ty) ty22) }
+ where
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+
+
+---------------------------
+mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
+ -> LHsExpr Name -> Fixity -- Operator and fixity
+ -> LHsExpr Name -- Right operand (not an OpApp, but might
+ -- be a NegApp)
+ -> RnM (HsExpr Name)
+
+-- (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)
+
+ | associate_right
+ = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
+ returnM (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)
+
+ | associate_right
+ = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
+ returnM (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)
+ where
+ (_, associate_right) = compareFixity fix1 negateFixity
+
+---------------------------
+-- Default case
+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)
+
+-- Parser left-associates everything, but
+-- derived instances may have correctly-associated things to
+-- in the right operarand. So we just check that the right operand is OK
+right_op_ok fix1 (OpApp _ _ fix2 _)
+ = not error_please && associate_right
+ where
+ (error_please, associate_right) = compareFixity fix1 fix2
+right_op_ok fix1 other
+ = True
+
+-- Parser initially makes negation bind more tightly than any other operator
+-- And "deriving" code should respect this (use HsPar if not)
+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)
+
+not_op_app (OpApp _ _ _ _) = False
+not_op_app other = True
+
+---------------------------
+mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
+ -> LHsExpr Name -> Fixity -- Operator and fixity
+ -> LHsCmdTop Name -- Right operand (not an infix)
+ -> RnM (HsCmd Name)
+
+-- (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])
+
+ | associate_right
+ = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
+ returnM (HsArrForm op1 (Just fix1)
+ [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
+ -- TODO: locs are wrong
+ where
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+
+-- Default case
+mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
+ = returnM (HsArrForm op (Just fix) [arg1, arg2])
+
-mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22)
- = lookupTyFixityRn op2 `thenM` \ fix2 ->
+--------------------------------------
+mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
+ -> RnM (Pat Name)
+
+mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
+ = lookupFixityRn (unLoc op1) `thenM` \ fix1 ->
let
(nofix_error, associate_right) = compareFixity fix1 fix2
in
if nofix_error then
- addErr (precParseErr (quotes (ppr op1),fix1)
- (quotes (ppr op2),fix2)) `thenM_`
- returnM (HsOpTy ty1 op1 ty2)
+ addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (ConPatIn op2 (InfixCon p1 p2))
else
- if not associate_right then
- -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
- mkHsOpTyRn op1 fix1 ty1 ty21 `thenM` \ new_ty ->
- returnM (HsOpTy new_ty op2 ty22)
+ if associate_right then
+ mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p ->
+ returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right?
else
- returnM (HsOpTy ty1 op1 ty2)
+ returnM (ConPatIn op2 (InfixCon p1 p2))
+
+mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment
+ = ASSERT( not_op_pat (unLoc p2) )
+ returnM (ConPatIn op (InfixCon p1 p2))
-mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment
- = returnM (HsOpTy ty1 op ty2)
+not_op_pat (ConPatIn _ (InfixCon _ _)) = False
+not_op_pat other = True
+
+--------------------------------------
+checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
+ -- True indicates an infix lhs
+ -- See comments with rnExpr (OpApp ...) about "deriving"
+
+checkPrecMatch False fn match
+ = returnM ()
+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
+
+ check _ = panic "checkPrecMatch"
+
+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) ->
+ let
+ inf_ok = op1_prec > op_prec ||
+ (op1_prec == op_prec &&
+ (op1_dir == InfixR && op_dir == InfixR && right ||
+ op1_dir == InfixL && op_dir == InfixL && not 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 ()
+
+-- Check precedence of (arg op) or (op arg) respectively
+-- If arg is itself an operator application, then either
+-- (a) its precedence must be higher than that of op
+-- (b) its precedency & associativity must be the same as that of op
+checkSectionPrec :: FixityDirection -> HsExpr RdrName
+ -> LHsExpr Name -> LHsExpr Name -> RnM ()
+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 ()
+ 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 _) ->
+ checkErr (op_prec < arg_prec
+ || op_prec == arg_prec && direction == assoc)
+ (sectionPrecErr (ppr_op op_name, op_fix)
+ (pp_arg_op, arg_fix) section)
+\end{code}
+
+Precedence-related error messages
+
+\begin{code}
+precParseErr op1 op2
+ = hang (ptext SLIT("precedence parsing error"))
+ 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
+ ppr_opfix op2,
+ ptext SLIT("in the same infix expression")])
-mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0
- = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change
- -- this if fixity of -> increases.
+sectionPrecErr op arg_op section
+ = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
+ nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
+ nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
-not_op_ty (HsOpTy _ _ _) = False
-not_op_ty other = True
+pp_prefix_minus = ptext SLIT("prefix `-'")
+ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
+ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnM RenamedContext
-rnContext doc ctxt
- = mappM rn_pred ctxt `thenM` \ theta ->
-
- -- Check for duplicate assertions
- -- If this isn't an error, then it ought to be:
- ifOptM Opt_WarnMisc (
- let
- (_, dups) = removeDupsEq theta
- -- We only have equality, not ordering
- in
- mappM_ (addWarn . dupClassAssertWarn theta) dups
- ) `thenM_`
-
- returnM theta
- where
- --Someone discovered that @CCallable@ and @CReturnable@
- -- could be used in contexts such as:
- -- foo :: CCallable a => a -> PrimIO Int
- -- Doing this utterly wrecks the whole point of introducing these
- -- classes so we specifically check that this isn't being done.
- rn_pred pred = rnPred doc pred `thenM` \ pred'->
- checkErr (not (bad_pred pred'))
- (naughtyCCallContextErr pred') `thenM_`
- returnM pred'
+rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
+rnContext doc = wrapLocM (rnContext' doc)
- bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
- bad_pred other = False
+rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
+rnContext' doc ctxt = mappM (rnLPred doc) ctxt
+rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
+rnLPred doc = wrapLocM (rnPred doc)
rnPred doc (HsClassP clas tys)
= lookupOccRn clas `thenM` \ clas_name ->
- rnHsTypes doc tys `thenM` \ tys' ->
+ rnLHsTypes doc tys `thenM` \ tys' ->
returnM (HsClassP clas_name tys')
rnPred doc (HsIParam n ty)
- = newIPName n `thenM` \ name ->
- rnHsType doc ty `thenM` \ ty' ->
+ = newIPNameRn n `thenM` \ name ->
+ rnLHsType doc ty `thenM` \ ty' ->
returnM (HsIParam name ty')
\end{code}
\begin{code}
rnPatsAndThen :: HsMatchContext Name
- -> [RdrNamePat]
- -> ([RenamedPat] -> RnM (a, FreeVars))
+ -> [LPat RdrName]
+ -> ([LPat Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- Bring into scope all the binders and type variables
-- bound by the patterns; then rename the patterns; then
rnPatsAndThen ctxt pats thing_inside
= bindPatSigTyVarsFV pat_sig_tys $
- bindLocalsFV doc_pat bndrs $ \ new_bndrs ->
- rnPats pats `thenM` \ (pats', pat_fvs) ->
+ bindLocatedLocalsFV doc_pat bndrs $ \ new_bndrs ->
+ rnLPats pats `thenM` \ (pats', pat_fvs) ->
thing_inside pats' `thenM` \ (res, res_fvs) ->
let
unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
in
- warnUnusedMatches unused_binders `thenM_`
-
+ warnUnusedMatches unused_binders `thenM_`
returnM (res, res_fvs `plusFV` pat_fvs)
where
pat_sig_tys = collectSigTysFromPats pats
- bndrs = collectPatsBinders pats
+ bndrs = collectLocatedPatsBinders pats
doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt
-rnPats :: [RdrNamePat] -> RnM ([RenamedPat], FreeVars)
-rnPats ps = mapFvRn rnPat ps
+rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
+rnLPats ps = mapFvRn rnLPat ps
+
+rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
+rnLPat = wrapLocFstM rnPat
-rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars)
+-- -----------------------------------------------------------------------------
+-- rnPat
+
+rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)
rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
= doptM Opt_GlasgowExts `thenM` \ glaExts ->
if glaExts
- then rnPat pat `thenM` \ (pat', fvs1) ->
+ then rnLPat pat `thenM` \ (pat', fvs1) ->
rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) ->
returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
else addErr (patSigErr ty) `thenM_`
- rnPat pat
+ rnPat (unLoc pat) -- XXX shouldn't throw away the loc
where
doc = text "In a pattern type-signature"
-rnPat (LitPat s@(HsString _))
- = returnM (LitPat s, unitFV eqStringName)
-
rnPat (LitPat lit)
- = litFVs lit `thenM` \ fvs ->
- returnM (LitPat lit, fvs)
+ = rnLit lit `thenM_`
+ returnM (LitPat lit, emptyFVs)
-rnPat (NPatIn lit mb_neg)
+rnPat (NPat lit mb_neg eq _)
= rnOverLit lit `thenM` \ (lit', fvs1) ->
(case mb_neg of
Nothing -> returnM (Nothing, emptyFVs)
Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->
returnM (Just neg, fvs)
) `thenM` \ (mb_neg', fvs2) ->
- returnM (NPatIn lit' mb_neg',
- fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
+ lookupSyntaxName eqName `thenM` \ (eq', fvs3) ->
+ returnM (NPat lit' mb_neg' eq' placeHolderType,
+ fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)
-- Needed to find equality on pattern
-rnPat (NPlusKPatIn name lit _)
+rnPat (NPlusKPat name lit _ _)
= rnOverLit lit `thenM` \ (lit', fvs1) ->
- lookupBndrRn name `thenM` \ name' ->
+ lookupLocatedBndrRn name `thenM` \ name' ->
lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
- returnM (NPlusKPatIn name' lit' minus,
- fvs1 `plusFV` fvs2 `addOneFV` integralClassName)
+ lookupSyntaxName geName `thenM` \ (ge, fvs3) ->
+ returnM (NPlusKPat name' lit' ge minus,
+ fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
-- The Report says that n+k patterns must be in Integral
rnPat (LazyPat pat)
- = rnPat pat `thenM` \ (pat', fvs) ->
+ = rnLPat pat `thenM` \ (pat', fvs) ->
returnM (LazyPat pat', fvs)
rnPat (AsPat name pat)
- = rnPat pat `thenM` \ (pat', fvs) ->
- lookupBndrRn name `thenM` \ vname ->
+ = rnLPat pat `thenM` \ (pat', fvs) ->
+ lookupLocatedBndrRn name `thenM` \ vname ->
returnM (AsPat vname pat', fvs)
rnPat (ConPatIn con stuff) = rnConPat con stuff
rnPat (ParPat pat)
- = rnPat pat `thenM` \ (pat', fvs) ->
+ = rnLPat pat `thenM` \ (pat', fvs) ->
returnM (ParPat pat', fvs)
rnPat (ListPat pats _)
- = rnPats pats `thenM` \ (patslist, fvs) ->
+ = rnLPats pats `thenM` \ (patslist, fvs) ->
returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
rnPat (PArrPat pats _)
- = rnPats pats `thenM` \ (patslist, fvs) ->
+ = rnLPats pats `thenM` \ (patslist, fvs) ->
returnM (PArrPat patslist placeHolderType,
fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
where
implicit_fvs = mkFVs [lengthPName, indexPName]
-rnPat (TuplePat pats boxed)
+rnPat (TuplePat pats boxed _)
= checkTupSize tup_size `thenM_`
- rnPats pats `thenM` \ (patslist, fvs) ->
- returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
+ rnLPats pats `thenM` \ (patslist, fvs) ->
+ returnM (TuplePat patslist boxed placeHolderType,
+ fvs `addOneFV` tycon_name)
where
tup_size = length pats
tycon_name = tupleTyCon_name boxed tup_size
rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
returnM (TypePat name', fvs)
-------------------------------
+-- -----------------------------------------------------------------------------
+-- rnConPat
+
rnConPat con (PrefixCon pats)
- = lookupOccRn con `thenM` \ con' ->
- rnPats pats `thenM` \ (pats', fvs) ->
- returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con')
+ = lookupLocatedOccRn con `thenM` \ con' ->
+ rnLPats pats `thenM` \ (pats', fvs) ->
+ returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')
rnConPat con (RecCon rpats)
- = lookupOccRn con `thenM` \ con' ->
- rnRpats rpats `thenM` \ (rpats', fvs) ->
- returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con')
+ = lookupLocatedOccRn con `thenM` \ con' ->
+ rnRpats rpats `thenM` \ (rpats', fvs) ->
+ returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')
rnConPat con (InfixCon pat1 pat2)
- = lookupOccRn con `thenM` \ con' ->
- rnPat pat1 `thenM` \ (pat1', fvs1) ->
- rnPat pat2 `thenM` \ (pat2', fvs2) ->
-
- getModeRn `thenM` \ mode ->
- -- See comments with rnExpr (OpApp ...)
- (if isInterfaceMode mode
- then returnM (ConPatIn con' (InfixCon pat1' pat2'))
- else lookupFixityRn con' `thenM` \ fixity ->
- mkConOpPatRn con' fixity pat1' pat2'
- ) `thenM` \ pat' ->
- returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
-
-------------------------
+ = lookupLocatedOccRn con `thenM` \ con' ->
+ rnLPat pat1 `thenM` \ (pat1', fvs1) ->
+ rnLPat pat2 `thenM` \ (pat2', fvs2) ->
+ lookupFixityRn (unLoc con') `thenM` \ fixity ->
+ mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' ->
+ returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con')
+
+-- -----------------------------------------------------------------------------
+-- rnRpats
+
+rnRpats :: [(Located RdrName, LPat RdrName)]
+ -> RnM ([(Located Name, LPat Name)], FreeVars)
rnRpats rpats
= mappM_ field_dup_err dup_fields `thenM_`
mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) ->
returnM (rpats', fvs)
where
- (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ]
+ (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
field_dup_err dups = addErr (dupFieldErr "pattern" dups)
rn_rpat (field, pat)
- = lookupGlobalOccRn field `thenM` \ fieldname ->
- rnPat pat `thenM` \ (pat', fvs) ->
- returnM ((fieldname, pat'), fvs `addOneFV` fieldname)
-\end{code}
+ = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
+ rnLPat pat `thenM` \ (pat', fvs) ->
+ returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
-\begin{code}
-mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat
- -> RnM RenamedPat
-
-mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2
- = lookupFixityRn op1 `thenM` \ fix1 ->
- let
- (nofix_error, associate_right) = compareFixity fix1 fix2
- in
- if nofix_error then
- addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
- returnM (ConPatIn op2 (InfixCon p1 p2))
- else
- if associate_right then
- mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p ->
- returnM (ConPatIn op1 (InfixCon p11 new_p))
- else
- returnM (ConPatIn op2 (InfixCon p1 p2))
-
-mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment
- = ASSERT( not_op_pat p2 )
- returnM (ConPatIn op (InfixCon p1 p2))
-
-not_op_pat (ConPatIn _ (InfixCon _ _)) = False
-not_op_pat other = True
\end{code}
are made available.
\begin{code}
-litFVs (HsChar c)
- = checkErr (inCharRange c) (bogusCharError c) `thenM_`
- returnM (unitFV charTyCon_name)
-
-litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon))
-litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name])
-litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon))
-litFVs (HsInt i) = returnM (unitFV (getName intTyCon))
-litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon))
-litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon))
-litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon))
-litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName)
-litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
- -- in post-typechecker translations
-bogusCharError c
- = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
+rnLit :: HsLit -> RnM ()
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit other = returnM ()
rnOverLit (HsIntegral i _)
= lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
-forAllWarn doc ty tyvar
+forAllWarn doc ty (L loc tyvar)
= ifOptM Opt_WarnUnusedMatches $
- getModeRn `thenM` \ mode ->
- case mode of {
-#ifndef DEBUG
- InterfaceMode _ -> returnM () ; -- Don't warn of unused tyvars in interface files
- -- unless DEBUG is on, in which case it is slightly
- -- informative. They can arise from mkRhsTyLam,
- -- leading to (say) f :: forall a b. [b] -> [b]
-#endif
- other ->
- addWarn (
- sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+ setSrcSpan loc $
+ addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
$$
doc
)
- }
-
-dupClassAssertWarn ctxt (assertion : dups)
- = sep [hsep [ptext SLIT("Duplicate class assertion"),
- quotes (ppr assertion),
- ptext SLIT("in the context:")],
- nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
-naughtyCCallContextErr (HsClassP clas _)
- = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
- ptext SLIT("in a context")]
-
-precParseErr op1 op2
- = hang (ptext SLIT("precedence parsing error"))
- 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
- ppr_opfix op2,
- ptext SLIT("in the same infix expression")])
-
-sectionPrecErr op arg_op section
- = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
- nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
- nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
-
-infixTyConWarn op
- = ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op)
+bogusCharError c
+ = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
patSigErr ty
= (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
$$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
-dupFieldErr str (dup:rest)
+dupFieldErr str dup
= hsep [ptext SLIT("duplicate field name"),
quotes (ppr dup),
ptext SLIT("in record"), text str]
-
-ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
-ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
\end{code}
projects / ghc-hetmet.git / blobdiff