X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnTypes.lhs;h=95f69b21875dd8fa60b908814334ddcfa58c5af0;hb=7331a887f634652f9d28ccbe0384cabb779c7ba3;hp=61a14ef2056ee1d068c3931944044427176c6ae8;hpb=f62fd70df7695286af55854911dad8a28eecb5e1;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 61a14ef..95f69b2 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -4,24 +4,41 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs, rnContext ) where +module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsSigType, rnHsTypeFVs, + rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part + rnLit, rnOverLit, -- of any mutual recursion + precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize + ) where -import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches) ) +import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn -import RdrHsSyn ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars ) -import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames, tupleTyCon_name ) -import RnEnv ( lookupOccRn, newIPName, bindTyVarsRn ) -import RnMonad - -import PrelInfo ( cCallishClassKeys ) -import RdrName ( elemRdrEnv ) -import NameSet ( FreeVars ) -import Unique ( Uniquable(..) ) - -import List ( nub ) -import ListSetOps ( removeDupsEq ) +import RdrHsSyn ( extractHsRhoRdrTyVars ) +import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, + listTyCon_name + ) +import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, + lookupLocatedOccRn, lookupLocatedBndrRn, + lookupLocatedGlobalOccRn, bindTyVarsRn, lookupFixityRn, + mapFvRn, warnUnusedMatches, + newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) +import TcRnMonad +import RdrName ( RdrName, elemLocalRdrEnv ) +import PrelNames ( eqClassName, integralClassName, + negateName, minusName, lengthPName, indexPName, + plusIntegerName, fromIntegerName, timesIntegerName, + ratioDataConName, fromRationalName ) +import Constants ( mAX_TUPLE_SIZE ) +import Name ( Name ) +import SrcLoc ( Located(..), unLoc ) +import NameSet + +import Literal ( inIntRange, inCharRange ) +import BasicTypes ( compareFixity ) +import ListSetOps ( removeDups ) import Outputable +import Monad ( when ) #include "HsVersions.h" \end{code} @@ -36,185 +53,522 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnHsTypeFVs doc_str ty - = rnHsType doc_str ty `thenRn` \ ty' -> - returnRn (ty', extractHsTyNames ty') + = rnLHsType doc_str ty `thenM` \ ty' -> + returnM (ty', extractHsTyNames ty') -rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) -rnHsSigTypeFVs doc_str ty - = rnHsSigType doc_str ty `thenRn` \ ty' -> - returnRn (ty', extractHsTyNames ty') - -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS 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 -> RnMS 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} - = getLocalNameEnv `thenRn` \ name_env -> + = getLocalRdrEnv `thenM` \ name_env -> let - mentioned_in_tau = extractHsTyRdrTyVars ty - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) - forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned + 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 . (`elemLocalRdrEnv` name_env) . unLoc) mentioned + tyvar_bndrs = [ L loc (UserTyVar v) | (L loc v) <- 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 - mapRn_ (forAllWarn doc tau) warn_guys `thenRn_` - rnForAll doc forall_tyvars ctxt tau + mappM_ (forAllWarn doc tau) warn_guys `thenM_` + rnForAll doc Explicit forall_tyvars ctxt tau rnHsType doc (HsTyVar tyvar) - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (HsTyVar tyvar') - -rnHsType doc (HsOpTy ty1 opname ty2) - = lookupOccRn opname `thenRn` \ name' -> - rnHsType doc ty1 `thenRn` \ ty1' -> - rnHsType doc ty2 `thenRn` \ ty2' -> - returnRn (HsOpTy ty1' name' ty2') + = lookupOccRn tyvar `thenM` \ tyvar' -> + returnM (HsTyVar tyvar') + +rnHsType doc (HsOpTy ty1 (L loc op) ty2) + = setSrcSpan loc ( + lookupOccRn op `thenM` \ op' -> + lookupTyFixityRn (L loc op') `thenM` \ fix -> + rnLHsType doc ty1 `thenM` \ ty1' -> + rnLHsType doc ty2 `thenM` \ ty2' -> + mkHsOpTyRn (L loc op') fix ty1' ty2' + ) + +rnHsType doc (HsParTy 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 = returnRn (HsNumTy i) - | otherwise = failWithRn (HsNumTy i) - (ptext SLIT("Only unit numeric type pattern is valid")) + | i == 1 = returnM (HsNumTy i) + | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i) + where + err_msg = ptext SLIT("Only unit numeric type pattern is valid") + rnHsType doc (HsFunTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ ty1' -> + = rnLHsType doc ty1 `thenM` \ ty1' -> -- Might find a for-all as the arg of a function type - rnHsType doc ty2 `thenRn` \ 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 - returnRn (HsFunTy ty1' ty2') + returnM (HsFunTy ty1' ty2') rnHsType doc (HsListTy ty) - = rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsListTy ty') + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsListTy ty') + +rnHsType doc (HsKindSig ty k) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsKindSig ty' k) + +rnHsType doc (HsPArrTy 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 (HsTupCon _ boxity arity) tys) - -- Don't do lookupOccRn, because this is built-in syntax - -- so it doesn't need to be in scope - = mapRn (rnHsType doc) tys `thenRn` \ tys' -> - returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys') - where - tup_name = tupleTyCon_name boxity arity - +rnHsType doc (HsTupleTy tup_con tys) + = mappM (rnLHsType doc) tys `thenM` \ tys' -> + returnM (HsTupleTy tup_con tys') rnHsType doc (HsAppTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ ty1' -> - rnHsType doc ty2 `thenRn` \ ty2' -> - returnRn (HsAppTy ty1' ty2') + = rnLHsType doc ty1 `thenM` \ ty1' -> + rnLHsType doc ty2 `thenM` \ ty2' -> + returnM (HsAppTy ty1' ty2') rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenRn` \ pred' -> - returnRn (HsPredTy pred') + = rnPred doc pred `thenM` \ pred' -> + returnM (HsPredTy pred') -rnHsTypes doc tys = mapRn (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 `thenRn` \ new_ctxt -> - rnHsType doc ty `thenRn` \ new_ty -> - returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) + rnContext doc ctxt `thenM` \ new_ctxt -> + 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} +%* * +%********************************************************* + +Infix types are read in a *right-associative* way, so that + a `op` b `op` c +is always read in as + a `op` (b `op` c) + +mkHsOpTyRn rearranges where necessary. The two arguments +have already been renamed and rearranged. It's made rather tiresome +by the presence of -> + \begin{code} -rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext -rnContext doc ctxt - = mapRn rn_pred ctxt `thenRn` \ theta -> - - -- Check for duplicate assertions - -- If this isn't an error, then it ought to be: - ifOptRn Opt_WarnMisc ( - let - (_, dups) = removeDupsEq theta - -- We only have equality, not ordering - in - mapRn (addWarnRn . dupClassAssertWarn theta) dups - ) `thenRn_` - - returnRn 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 `thenRn` \ pred'-> - checkRn (not (bad_pred pred')) - (naughtyCCallContextErr pred') `thenRn_` - returnRn pred' +lookupTyFixityRn (L loc n) + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + when (not glaExts) + (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` + lookupFixityRn n + +-- Building (ty1 `op1` (ty21 `op2` ty22)) +mkHsOpTyRn :: Located Name -> Fixity + -> LHsType Name -> LHsType Name + -> RnM (HsType Name) + +mkHsOpTyRn op1 fix1 ty1 ty2@(L loc (HsOpTy ty21 op2 ty22)) + = lookupTyFixityRn op2 `thenM` \ fix2 -> + 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) + else + if not associate_right then + -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + mkHsOpTyRn op1 fix1 ty1 ty21 `thenM` \ new_ty -> + returnM (HsOpTy (L loc new_ty) op2 ty22) -- XXX loc is wrong + else + returnM (HsOpTy ty1 op1 ty2) + +mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment + = returnM (HsOpTy ty1 op ty2) +\end{code} - bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys - bad_pred other = False +%********************************************************* +%* * +\subsection{Contexts and predicates} +%* * +%********************************************************* + +\begin{code} +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 +rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) +rnLPred doc = wrapLocM (rnPred doc) rnPred doc (HsClassP clas tys) - = lookupOccRn clas `thenRn` \ clas_name -> - rnHsTypes doc tys `thenRn` \ tys' -> - returnRn (HsClassP clas_name tys') + = lookupOccRn clas `thenM` \ clas_name -> + rnLHsTypes doc tys `thenM` \ tys' -> + returnM (HsClassP clas_name tys') rnPred doc (HsIParam n ty) - = newIPName n `thenRn` \ name -> - rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsIParam name ty') + = newIPNameRn n `thenM` \ name -> + rnLHsType doc ty `thenM` \ ty' -> + returnM (HsIParam name ty') +\end{code} + + +********************************************************* +* * +\subsection{Patterns} +* * +********************************************************* + +\begin{code} +rnPatsAndThen :: HsMatchContext Name + -> Bool + -> [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 +-- do the thing inside. +-- +-- Note that we do a single bindLocalsRn for all the +-- matches together, so that we spot the repeated variable in +-- f x x = 1 + +rnPatsAndThen ctxt repUnused pats thing_inside + = bindPatSigTyVarsFV pat_sig_tys $ + 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 + (if repUnused + then warnUnusedMatches unused_binders + else returnM ()) `thenM_` + returnM (res, res_fvs `plusFV` pat_fvs) + where + pat_sig_tys = collectSigTysFromPats pats + bndrs = collectLocatedPatsBinders pats + doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt + +rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars) +rnLPats ps = mapFvRn rnLPat ps + +rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars) +rnLPat = wrapLocFstM rnPat + +-- ----------------------------------------------------------------------------- +-- rnPat + +rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars) + +rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) + +rnPat (VarPat name) + = lookupBndrRn name `thenM` \ vname -> + returnM (VarPat vname, emptyFVs) + +rnPat (SigPatIn pat ty) + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + + if glaExts + 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 (unLoc pat) -- XXX shouldn't throw away the loc + where + doc = text "In a pattern type-signature" + +rnPat (LitPat lit) + = rnLit lit `thenM_` + returnM (LitPat lit, emptyFVs) + +rnPat (NPatIn lit mb_neg) + = 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) + -- Needed to find equality on pattern + +rnPat (NPlusKPatIn name lit _) + = rnOverLit lit `thenM` \ (lit', fvs1) -> + lookupLocatedBndrRn name `thenM` \ name' -> + lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> + returnM (NPlusKPatIn name' lit' minus, + fvs1 `plusFV` fvs2 `addOneFV` integralClassName) + -- The Report says that n+k patterns must be in Integral + +rnPat (LazyPat pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + returnM (LazyPat pat', fvs) + +rnPat (AsPat name pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + lookupLocatedBndrRn name `thenM` \ vname -> + returnM (AsPat vname pat', fvs) + +rnPat (ConPatIn con stuff) = rnConPat con stuff + + +rnPat (ParPat pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + returnM (ParPat pat', fvs) + +rnPat (ListPat pats _) + = rnLPats pats `thenM` \ (patslist, fvs) -> + returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) + +rnPat (PArrPat pats _) + = 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) + = checkTupSize tup_size `thenM_` + rnLPats pats `thenM` \ (patslist, fvs) -> + returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name) + where + tup_size = length pats + tycon_name = tupleTyCon_name boxed tup_size + +rnPat (TypePat name) = + rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> + returnM (TypePat name', fvs) + +-- ----------------------------------------------------------------------------- +-- rnConPat + +rnConPat con (PrefixCon pats) + = lookupLocatedOccRn con `thenM` \ con' -> + rnLPats pats `thenM` \ (pats', fvs) -> + returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') + +rnConPat con (RecCon rpats) + = lookupLocatedOccRn con `thenM` \ con' -> + rnRpats rpats `thenM` \ (rpats', fvs) -> + returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') + +rnConPat con (InfixCon pat1 pat2) + = 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 [ unLoc f | (f,_) <- rpats ] + + field_dup_err dups = addErr (dupFieldErr "pattern" dups) + + rn_rpat (field, pat) + = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> + rnLPat pat `thenM` \ (pat', fvs) -> + returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname) + +-- ----------------------------------------------------------------------------- +-- mkConOpPatRn + +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 (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 (L loc new_p))) -- XXX loc right? + else + 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 \end{code} + +%************************************************************************ +%* * +\subsubsection{Literals} +%* * +%************************************************************************ + +When literals occur we have to make sure +that the types and classes they involve +are made available. + +\begin{code} +rnLit :: HsLit -> RnM () +rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) +rnLit other = returnM () + +rnOverLit (HsIntegral i _) + = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> + if inIntRange i then + returnM (HsIntegral i from_integer_name, fvs) + else let + extra_fvs = mkFVs [plusIntegerName, timesIntegerName] + -- Big integer literals are built, using + and *, + -- out of small integers (DsUtils.mkIntegerLit) + -- [NB: plusInteger, timesInteger aren't rebindable... + -- they are used to construct the argument to fromInteger, + -- which is the rebindable one.] + in + returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) + +rnOverLit (HsFractional i _) + = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> + let + extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] + -- We have to make sure that the Ratio type is imported with + -- its constructor, because literals of type Ratio t are + -- built with that constructor. + -- The Rational type is needed too, but that will come in + -- as part of the type for fromRational. + -- The plus/times integer operations may be needed to construct the numerator + -- and denominator (see DsUtils.mkIntegerLit) + in + returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) \end{code} + + + +%********************************************************* +%* * +\subsection{Errors} +%* * +%********************************************************* + \begin{code} -forAllWarn doc ty tyvar - = ifOptRn Opt_WarnUnusedMatches $ - getModeRn `thenRn` \ mode -> - case mode of { -#ifndef DEBUG - InterfaceMode -> returnRn () ; -- 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 -> - addWarnRn ( - sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = returnM () + | otherwise + = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"), + 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 (L loc tyvar) + = ifOptM Opt_WarnUnusedMatches $ + 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")] -\end{code} \ No newline at end of file + +bogusCharError c + = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' + +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 + = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), + ftext FSLIT("Use -fglasgow-exts to avoid this warning")] + +patSigErr ty + = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) + $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it")) + +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}