X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnTypes.lhs;h=227cce53569dd90f8cf6f704e163c0e18682bf74;hb=4e5d22a241b6347c462cf7748e13effde0f02720;hp=121cf076031cebabaebcfe3ebd891bb8423cb039;hpb=5ed839230368ddf2d7804513931abf9bb787d415;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 121cf07..227cce5 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -11,35 +11,32 @@ module RnTypes ( rnHsType, rnContext, precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize ) where -import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) ) +import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNamePat, - extractHsTyRdrTyVars, extractHsCtxtRdrTyVars ) + extractHsRhoRdrTyVars ) import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat, extractHsTyNames, parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, - newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn, + bindTyVarsRn, lookupFixityRn, mapFvRn, newIPNameRn, bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches ) import TcRnMonad - -import PrelNames( cCallishClassKeys, eqStringName, eqClassName, integralClassName, +import RdrName ( elemLocalRdrEnv ) +import PrelNames( eqStringName, eqClassName, integralClassName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, - timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName ) + timesIntegerName, ratioDataConName, fromRationalName ) import Constants ( mAX_TUPLE_SIZE ) import TysWiredIn ( intTyCon ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import RdrName ( elemRdrEnv ) import Name ( Name, NamedThing(..) ) import NameSet -import Unique ( Uniquable(..) ) import Literal ( inIntRange, inCharRange ) -import BasicTypes ( compareFixity, arrowFixity ) -import List ( nub ) -import ListSetOps ( removeDupsEq, removeDups ) +import BasicTypes ( compareFixity ) +import ListSetOps ( removeDups ) import Outputable #include "HsVersions.h" @@ -78,50 +75,42 @@ want a gratuitous knot. \begin{code} rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType -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)) mentioned in - rnForAll doc (map UserTyVar forall_tyvars) ctxt ty + rnForAll doc Implicit (map UserTyVar forall_tyvars) 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 = extractHsRhoRdrTyVars ctxt tau + forall_tyvar_names = hsTyVarNames forall_tyvars -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter (`notElem` mentioned) forall_tyvar_names + warn_guys = filter (`notElem` mentioned) 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' -> + = lookupOccRn op `thenM` \ op' -> rnHsType doc ty1 `thenM` \ ty1' -> rnHsType doc ty2 `thenM` \ ty2' -> lookupTyFixityRn op' `thenM` \ fix -> @@ -178,11 +167,22 @@ rnHsTypes doc tys = mappM (rnHsType doc) tys \begin{code} -rnForAll doc forall_tyvars ctxt ty +rnForAll doc exp [] [] ty = rnHsType doc ty + -- One reason for this case is that a type like Int# + -- starts of 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) + 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} @@ -202,14 +202,13 @@ have already been renamed and rearranged. It's made rather tiresome by the presence of -> \begin{code} -lookupTyFixityRn HsArrow = returnM arrowFixity -lookupTyFixityRn (HsTyOp n) +lookupTyFixityRn n = doptM Opt_GlasgowExts `thenM` \ glaExts -> warnIf (not glaExts) (infixTyConWarn n) `thenM_` lookupFixityRn n -- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: HsTyOp Name -> Fixity +mkHsOpTyRn :: Name -> Fixity -> RenamedHsType -> RenamedHsType -> RnM RenamedHsType @@ -232,13 +231,6 @@ mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22) mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment = returnM (HsOpTy ty1 op ty2) - -mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0 - = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change - -- this if fixity of -> increases. - -not_op_ty (HsOpTy _ _ _) = False -not_op_ty other = True \end{code} %********************************************************* @@ -249,34 +241,7 @@ 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' - - bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys - bad_pred other = False - +rnContext doc ctxt = mappM (rnPred doc) ctxt rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenM` \ clas_name -> @@ -284,7 +249,7 @@ rnPred doc (HsClassP clas tys) returnM (HsClassP clas_name tys') rnPred doc (HsIParam n ty) - = newIPName n `thenM` \ name -> + = newIPNameRn n `thenM` \ name -> rnHsType doc ty `thenM` \ ty' -> returnM (HsIParam name ty') \end{code} @@ -298,6 +263,7 @@ rnPred doc (HsIParam n ty) \begin{code} rnPatsAndThen :: HsMatchContext Name + -> Bool -> [RdrNamePat] -> ([RenamedPat] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) @@ -309,7 +275,7 @@ rnPatsAndThen :: HsMatchContext Name -- matches together, so that we spot the repeated variable in -- f x x = 1 -rnPatsAndThen ctxt pats thing_inside +rnPatsAndThen ctxt repUnused pats thing_inside = bindPatSigTyVarsFV pat_sig_tys $ bindLocalsFV doc_pat bndrs $ \ new_bndrs -> rnPats pats `thenM` \ (pats', pat_fvs) -> @@ -318,8 +284,9 @@ rnPatsAndThen ctxt pats thing_inside let unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs in - warnUnusedMatches unused_binders `thenM_` - + (if repUnused + then warnUnusedMatches unused_binders + else returnM ()) `thenM_` returnM (res, res_fvs `plusFV` pat_fvs) where pat_sig_tys = collectSigTysFromPats pats @@ -427,17 +394,11 @@ rnConPat con (RecCon rpats) returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` 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' -> + = lookupOccRn con `thenM` \ con' -> + rnPat pat1 `thenM` \ (pat1', fvs1) -> + rnPat pat2 `thenM` \ (pat2', fvs2) -> + lookupFixityRn con' `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') ------------------------ @@ -506,7 +467,6 @@ 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 @@ -561,31 +521,11 @@ checkTupSize tup_size forAllWarn doc ty 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), + 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")) @@ -612,4 +552,4 @@ dupFieldErr str (dup:rest) 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}