X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnTypes.lhs;h=bfd02896647e346568d6088cdd4a42513519eb62;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=19cec112d0dab7e5e6c3d40b5a8868fa210a3eab;hpb=84ed91abfe3f9df43d5b33e404138e43a574beb8;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 19cec11..bfd0289 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -4,42 +4,52 @@ \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, ordClassName, - 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" @@ -55,82 +65,82 @@ to break several loop. %********************************************************* \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) @@ -139,59 +149,84 @@ rnHsType doc (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 @@ -199,46 +234,242 @@ 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)) + +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 -mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment - = returnM (HsOpTy ty1 op ty2) + check _ = panic "checkPrecMatch" -mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0 - = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change - -- this if fixity of -> increases. +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) -not_op_ty (HsOpTy _ _ _) = False -not_op_ty other = True +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")]) + +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))] + +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} %********************************************************* @@ -248,44 +479,23 @@ not_op_ty other = True %********************************************************* \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} @@ -298,8 +508,8 @@ rnPred doc (HsIParam n ty) \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 @@ -311,25 +521,30 @@ rnPatsAndThen :: HsMatchContext Name 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 -rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars) +rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars) rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) @@ -341,71 +556,72 @@ rnPat (SigPatIn pat ty) = 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` ordClassName) + 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 @@ -414,72 +630,46 @@ rnPat (TypePat name) = 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} @@ -494,22 +684,9 @@ that the types and classes they involve 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) -> @@ -558,57 +735,24 @@ checkTupSize tup_size 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, -#endif -- leading to (say) f :: forall a b. [b] -> [b] - 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} \ No newline at end of file +\end{code}