X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=2ae46bf0d27d6623b5044bbe4b91031069107b15;hp=e7a781c6439f8e51e941fc95cb6311d7b311941a;hb=c1500e4888be2341c0b6e6897f494766c86feba0;hpb=7502efdcd468b9a77385c5456481cf39f8eec79f diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e7a781c..2ae46bf 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,60 +9,40 @@ type-synonym declarations; those cannot be done at this stage because they may be affected by renaming (which isn't fully worked out yet). \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings rnMethodBinds, renameSigs, mkSigTvFn, rnMatchGroup, rnGRHSs, - makeMiniFixityEnv + makeMiniFixityEnv, MiniFixityEnv ) where -#include "HsVersions.h" - import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch) +import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, - NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, - patSigErr) + NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker + ) -import RnEnv ( lookupLocatedBndrRn, - lookupInstDeclBndr, newIPNameRn, - lookupLocatedSigOccRn, bindPatSigTyVarsFV, - bindLocalFixities, bindSigTyVarsFV, - warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, - bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV, - bindLocalNamesFV_WithFixities, - bindLocatedLocalsRn, - checkDupAndShadowedRdrNames - ) +import RnEnv +import PrelNames ( mkUnboundName ) import DynFlags ( DynFlag(..) ) -import HscTypes (FixItem(..)) import Name import NameEnv -import LazyUniqFM import NameSet -import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) -import SrcLoc ( Located(..), unLoc, noLoc ) +import SrcLoc import ListSetOps ( findDupsEq ) import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Bag import Outputable import FastString +import Data.List ( partition ) import Maybes ( orElse ) -import Util ( filterOut ) import Monad ( foldM, unless ) \end{code} @@ -175,8 +155,7 @@ it expects the global environment to contain bindings for the binders \begin{code} -- for top-level bindings, we need to make top-level names, -- so we have a different entry point than for local bindings -rnTopBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names +rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds = @@ -200,7 +179,7 @@ rnTopBindsRHS bound_names binds = rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = - do nl <- rnTopBindsLHS emptyUFM b + do nl <- rnTopBindsLHS emptyFsEnv b let bound_names = map unLoc (collectHsValBinders nl) bindLocalNames bound_names $ rnTopBindsRHS bound_names nl @@ -210,8 +189,9 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; sigs' <- renameSigs okHsBootSig sigs + ; sigs' <- renameSigs Nothing okHsBootSig sigs ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } +rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -241,11 +221,12 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do (thing, fvs_thing) <- thing_inside (HsIPBinds binds') return (thing, fvs_thing `plusFV` fv_binds) - +rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars) rnIPBinds (IPBinds ip_binds _no_dict_binds) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) +rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) rnIPBind (IPBind n expr) = do name <- newIPNameRn n (expr',fvExpr) <- rnLExpr expr @@ -262,8 +243,7 @@ rnIPBind (IPBind n expr) = do \begin{code} -- wrapper for local binds -- creates the documentation info and calls the helper below -rnValBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names +rnValBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS fix_env binds = @@ -274,8 +254,7 @@ rnValBindsLHS fix_env binds = -- just so we don't forget to do it somewhere rnValBindsLHSFromDoc_Local :: [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) -> SDoc -- doc string for dup names and shadowing - -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names + -> MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) @@ -314,15 +293,16 @@ rnValBindsLHSFromDoc :: NameMaker -> SDoc -- doc string for dup names and shadowing -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) -rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs) = do +rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do -- rename the LHSes mbinds' <- mapBagM (rnBindLHS topP doc) mbinds return $ ValBindsIn mbinds' sigs +rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) --- assumes the LHS vars are in scope --- general version used both from the top-level and for local things +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope -- --- does not bind the local fixity declarations +-- Does not bind the local fixity declarations rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -- The trimming function trims the free vars we attach to a -- binding so that it stays reasonably small @@ -330,19 +310,20 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do +rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do -- rename the sigs - sigs' <- rename_sigs sigs + env <- getGblEnv + traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env)) + sigs' <- renameSigs (Just (mkNameSet bound_names)) okBindSig sigs -- rename the RHSes binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds let (anal_binds, anal_dus) = depAnalBinds binds_w_dus (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs', usesOnly (hsSigsFVs sigs') `plusDU` anal_dus) - -- We do the check-sigs after renaming the bindings, - -- so that we have convenient access to the binders - check_sigs (okBindSig (duDefs anal_dus)) sigs' return (valbind', valbind'_dus) +rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) + -- Wrapper for local binds -- -- The *client* of this function is responsible for checking for unused binders; @@ -411,7 +392,8 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside ; return (result, all_uses) }} -- The bound names are pruned out of all_uses -- by the bindLocalNamesFV call above - + +rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs) -- Process the fixity declarations, making a FastString -> (Located Fixity) map @@ -420,37 +402,31 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside -- Checks for duplicates, but not that only locally defined things are fixed. -- Note: for local fixity declarations, duplicates would also be checked in -- check_sigs below. But we also use this function at the top level. -makeMiniFixityEnv :: [LFixitySig RdrName] - -> RnM (UniqFM (Located Fixity)) -- key is the FastString of the OccName - -- of the fixity declaration it came from - -makeMiniFixityEnv decls = foldlM add_one emptyUFM decls + +makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls where add_one env (L loc (FixitySig (L name_loc name) fixity)) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because -- definitions of non-local will be caught elsewhere) - let {occ = rdrNameOcc name; - curKey = occNameFS occ; - fix_item = L loc fixity}; + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; - case lookupUFM env curKey of - Nothing -> return $ addToUFM env curKey fix_item + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addLocErr (L name_loc name) (dupFixityDecl loc') + addLocErr (L name_loc name) (dupFixityDecl loc') ; return env} } -pprFixEnv :: NameEnv FixItem -> SDoc -pprFixEnv env - = pprWithCommas (\ (FixItem n f) -> ppr f <+> ppr n) - (nameEnvElts env) - +dupFixityDecl :: SrcSpan -> RdrName -> SDoc dupFixityDecl loc rdr_name - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("also at ") <+> ppr loc] + = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] --------------------- @@ -464,11 +440,10 @@ rnBindLHS :: NameMaker -- (i.e., any free variables of the pattern) -> RnM (LHsBindLR Name RdrName) -rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss, - bind_fvs=bind_fvs, - pat_rhs_ty=pat_rhs_ty - })) +rnBindLHS name_maker _ (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss, + pat_rhs_ty=pat_rhs_ty + })) = setSrcSpan loc $ do -- we don't actually use the FV processing of rnPatsAndThen here (pat',pat'_fvs) <- rnBindPat name_maker pat @@ -482,13 +457,12 @@ rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat, -- when we rename the RHS pat_rhs_ty = pat_rhs_ty })) -rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _), - fun_infix = inf, - fun_matches = matches, - fun_co_fn = fun_co_fn, - bind_fvs = bind_fvs, - fun_tick = fun_tick - })) +rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _), + fun_infix = inf, + fun_matches = matches, + fun_co_fn = fun_co_fn, + fun_tick = fun_tick + })) = setSrcSpan loc $ do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname -> return (newname, emptyFVs) @@ -503,15 +477,18 @@ rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _), fun_tick = fun_tick })) } +rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b) + -- assumes the left-hands-side vars are in scope rnBind :: (Name -> [Name]) -- Signature tyvar function -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars -> LHsBindLR Name RdrName -> RnM (LHsBind Name, [Name], Uses) -rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss, - -- pat fvs were stored here while processing the LHS - bind_fvs=pat_fvs })) +rnBind _ trim (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss, + -- pat fvs were stored here while + -- processing the LHS + bind_fvs=pat_fvs })) = setSrcSpan loc $ do {let bndrs = collectPatBinders pat @@ -550,6 +527,8 @@ rnBind sig_fn fun_tick = Nothing }), [plain_name], fvs) } + +rnBind _ _ b = pprPanic "rnBind" (ppr b) --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) @@ -572,7 +551,7 @@ depAnalBinds binds_w_dus , bndr <- bndrs ] get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) - get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus]) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) get_du (CyclicSCC binds_w_dus) = (Just defs, uses) @@ -637,6 +616,11 @@ rnMethodBinds cls sig_fn gen_tyvars binds (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) +rnMethodBind :: Name + -> (Name -> [Name]) + -> [Name] + -> LHsBindLR RdrName RdrName + -> RnM (Bag (LHsBindLR Name Name), FreeVars) rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ do @@ -671,9 +655,11 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do +rnMethodBind _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do addLocErr mbind methodBindErr return (emptyBag, emptyFVs) + +rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) \end{code} @@ -688,41 +674,26 @@ rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do \begin{enumerate} \item more than one sig for one thing; \item signatures given for things not bound here; -\item with suitably flaggery, that all top-level things have type signatures. \end{enumerate} % At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name] +renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns + -> (Sig RdrName -> Bool) -- Complain about the wrong kind of signature if this is False + -> [LSig RdrName] + -> RnM [LSig Name] -- Renames the signatures and performs error checks -renameSigs ok_sig sigs - = do { sigs' <- rename_sigs sigs - ; check_sigs ok_sig sigs' - ; return sigs' } - ----------------------- -rename_sigs :: [LSig RdrName] -> RnM [LSig Name] -rename_sigs sigs = mapM (wrapLocM renameSig) sigs +renameSigs mb_names ok_sig sigs + = do { let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs + ; mapM_ unknownSigErr bad_sigs -- Misplaced + ; mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) good_sigs + ; return sigs' } ---------------------- -check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () --- Used for class and instance decls, as well as regular bindings -check_sigs ok_sig sigs = do - -- Check for (a) duplicate signatures - -- (b) signatures for things not in this group = do - traceRn (text "SIGS" <+> ppr sigs) - mapM_ unknownSigErr (filter (not . ok_sig) sigs') - mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs') - where - -- Don't complain about an unbound name again - sigs' = filterOut bad_name sigs - bad_name sig = case sigName sig of - Just n -> isUnboundName n - other -> False - --- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} @@ -731,29 +702,77 @@ check_sigs ok_sig sigs = do -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: Sig RdrName -> RnM (Sig Name) --- FixitSig is renamed elsewhere. -renameSig (TypeSig v ty) = do - new_v <- lookupLocatedSigOccRn v - new_ty <- rnHsSigType (quotes (ppr v)) ty - return (TypeSig new_v new_ty) - -renameSig (SpecInstSig ty) = do - new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty - return (SpecInstSig new_ty) - -renameSig (SpecSig v ty inl) = do - new_v <- lookupLocatedSigOccRn v - new_ty <- rnHsSigType (quotes (ppr v)) ty - return (SpecSig new_v new_ty inl) - -renameSig (InlineSig v s) = do - new_v <- lookupLocatedSigOccRn v - return (InlineSig new_v s) - -renameSig (FixSig (FixitySig v f)) = do - new_v <- lookupLocatedSigOccRn v - return (FixSig (FixitySig new_v f)) +renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) +-- FixitySig is renamed elsewhere. +renameSig mb_names sig@(TypeSig v ty) + = do { new_v <- lookupSigOccRn mb_names sig v + ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; return (TypeSig new_v new_ty) } + +renameSig _ (SpecInstSig ty) + = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty + ; return (SpecInstSig new_ty) } + +renameSig mb_names sig@(SpecSig v ty inl) + = do { new_v <- lookupSigOccRn mb_names sig v + ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; return (SpecSig new_v new_ty inl) } + +renameSig mb_names sig@(InlineSig v s) + = do { new_v <- lookupSigOccRn mb_names sig v + ; return (InlineSig new_v s) } + +renameSig mb_names sig@(FixSig (FixitySig v f)) + = do { new_v <- lookupSigOccRn mb_names sig v + ; return (FixSig (FixitySig new_v f)) } + +-- lookupSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- It's clear that the 'f' in the signature must refer to A.f +-- The Haskell98 report does not stipulate this, but it will! +-- So we must treat the 'f' in the signature in the same way +-- as the binding occurrence of 'f', using lookupBndrRn +-- +-- However, consider this case: +-- import M( f ) +-- f :: Int -> Int +-- g x = x +-- We don't want to say 'f' is out of scope; instead, we want to +-- return the imported 'f', so that later on the reanamer will +-- correctly report "misplaced type sig". + +lookupSigOccRn :: Maybe NameSet -> Sig RdrName -> Located RdrName -> RnM (Located Name) +lookupSigOccRn mb_names sig (L loc v) + = do { mb_n <- lookupBndrRn_maybe v + ; case mb_n of { + Just n -> case mb_names of { + Nothing -> return (L loc n) ; + Just ns | n `elemNameSet` ns -> return (L loc n) + | otherwise -> bale_out_with local_msg } ; + + Nothing -> do + { mb_n <- lookupGreRn_maybe v + ; case mb_n of + Just _ -> bale_out_with import_msg + Nothing -> bale_out_with empty + } }} + where + bale_out_with msg + = do { addErr (sep [ ptext (sLit "The") <+> hsSigDoc sig + <+> ptext (sLit "for") <+> quotes (ppr v) + , nest 2 $ ptext (sLit "lacks an accompanying binding")] + $$ nest 2 msg) + ; return (L loc (mkUnboundName v)) } + + local_msg = parens $ ptext (sLit "The") <+> hsSigDoc sig <+> ptext (sLit "must be given where") + <+> quotes (ppr v) <+> ptext (sLit "is declared") + + import_msg = parens $ ptext (sLit "You cannot give a") <+> hsSigDoc sig + <+> ptext (sLit "an imported value") \end{code} @@ -772,31 +791,28 @@ rnMatchGroup ctxt (MatchGroup ms _) = do rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) +rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) - = - -- Deal with the rhs type signature - bindPatSigTyVarsFV rhs_sig_tys $ do - opt_PatternSignatures <- doptM Opt_PatternSignatures - (maybe_rhs_sig', ty_fvs) <- - case maybe_rhs_sig of - Nothing -> return (Nothing, emptyFVs) - Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty - return (Just ty', ty_fvs) - | otherwise -> do addLocErr ty patSigErr - return (Nothing, emptyFVs) - - -- Now the main event - -- note that there are no local ficity decls for matches - rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do - (grhss', grhss_fvs) <- rnGRHSs ctxt grhss - - return (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) + = do { -- Result type signatures are no longer supported + case maybe_rhs_sig of + Nothing -> return () + Just ty -> addLocErr ty (resSigErr ctxt match) + + + -- Now the main event + -- note that there are no local ficity decls for matches + ; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss + + ; return (Match pats' Nothing grhss', grhss_fvs) }} -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs where - rhs_sig_tys = case maybe_rhs_sig of - Nothing -> [] - Just ty -> [ty] - doc_sig = text "In a result type-signature" + +resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc +resSigErr ctxt match ty + = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) + , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") + , pprMatchInCtxt ctxt match ] \end{code} @@ -817,6 +833,7 @@ rnGRHSs ctxt (GRHSs grhss binds) rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) +rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars) rnGRHS' ctxt (GRHS guards rhs) = do { pattern_guards_allowed <- doptM Opt_PatternGuards ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ @@ -832,7 +849,7 @@ rnGRHS' ctxt (GRHS guards rhs) -- Glasgow extension is_standard_guard [] = True is_standard_guard [L _ (ExprStmt _ _ _)] = True - is_standard_guard other = False + is_standard_guard _ = False \end{code} %************************************************************************ @@ -842,39 +859,33 @@ rnGRHS' ctxt (GRHS guards rhs) %************************************************************************ \begin{code} +dupSigDeclErr :: [LSig RdrName] -> RnM () dupSigDeclErr sigs@(L loc sig : _) = addErrAt loc $ - vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon, nest 2 (vcat (map ppr_sig sigs))] where what_it_is = hsSigDoc sig ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig +dupSigDeclErr [] = panic "dupSigDeclErr" +unknownSigErr :: LSig RdrName -> RnM () unknownSigErr (L loc sig) - = do { mod <- getModule - ; addErrAt loc $ - vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig], - extra_stuff mod sig] } - where - what_it_is = hsSigDoc sig - extra_stuff mod (TypeSig (L _ n) _) - | nameIsLocalOrFrom mod n - = ptext SLIT("The type signature must be given where") - <+> quotes (ppr n) <+> ptext SLIT("is declared") - | otherwise - = ptext SLIT("You cannot give a type signature for an imported value") - - extra_stuff mod other = empty + = addErrAt loc $ + sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] +methodBindErr :: HsBindLR RdrName RdrName -> SDoc methodBindErr mbind - = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations")) + = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations")) 2 (ppr mbind) +bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc bindsInHsBootFile mbinds - = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) + = hang (ptext (sLit "Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) +nonStdGuardErr :: [LStmtLR Name Name] -> SDoc nonStdGuardErr guards - = hang (ptext SLIT("accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) + = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) \end{code}