From 4385caba003064bb556f965b32fdc962ea19ea69 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 20 May 2008 14:30:48 +0000 Subject: [PATCH] Fix Trac #2292: improve error message for lone signatures Refactoring reduces code and improves error messages --- compiler/hsSyn/HsBinds.lhs | 33 ++++---- compiler/rename/RnBinds.lhs | 170 +++++++++++++++++++++++------------------- compiler/rename/RnEnv.lhs | 31 +------- compiler/rename/RnSource.lhs | 7 +- 4 files changed, 114 insertions(+), 127 deletions(-) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 06a7bcc..8847e62 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -86,7 +86,7 @@ data HsBindLR idL idR -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds -- -- Reason 2: instance decls can only have FunBinds, which is convenient --- If you change this, you'll need tochange e.g. rnMethodBinds +-- If you change this, you'll need to change e.g. rnMethodBinds -- But note that the form f :: a->a = ... -- parses as a pattern binding, just like @@ -465,25 +465,22 @@ isSpecPrag _ = False \end{code} \begin{code} -okBindSig :: NameSet -> LSig Name -> Bool -okBindSig ns sig = sigForThisGroup ns sig +okBindSig :: Sig a -> Bool +okBindSig _ = True -okHsBootSig :: LSig Name -> Bool -okHsBootSig (L _ (TypeSig _ _)) = True -okHsBootSig (L _ (FixSig _)) = True -okHsBootSig _ = False +okHsBootSig :: Sig a -> Bool +okHsBootSig (TypeSig _ _) = True +okHsBootSig (FixSig _) = True +okHsBootSig _ = False -okClsDclSig :: LSig Name -> Bool -okClsDclSig (L _ (SpecInstSig _)) = False -okClsDclSig _ = True -- All others OK +okClsDclSig :: Sig a -> Bool +okClsDclSig (SpecInstSig _) = False +okClsDclSig _ = True -- All others OK -okInstDclSig :: NameSet -> LSig Name -> Bool -okInstDclSig ns lsig@(L _ sig) = ok ns sig - where - ok _ (TypeSig _ _) = False - ok _ (FixSig _) = False - ok _ (SpecInstSig _) = True - ok ns _ = sigForThisGroup ns lsig +okInstDclSig :: Sig a -> Bool +okInstDclSig (TypeSig _ _) = False +okInstDclSig (FixSig _) = False +okInstDclSig _ = True sigForThisGroup :: NameSet -> LSig Name -> Bool sigForThisGroup ns sig @@ -539,7 +536,7 @@ hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration") Signature equality is used when checking for duplicate signatures \begin{code} -eqHsSig :: LSig Name -> LSig Name -> Bool +eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 08b54c5..6ca3bdb 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -28,11 +28,11 @@ import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, patSigErr) import RnEnv +import PrelNames ( mkUnboundName ) import DynFlags ( DynFlag(..) ) import Name import NameEnv import NameSet -import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) @@ -41,8 +41,8 @@ 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} @@ -189,7 +189,7 @@ 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} @@ -299,10 +299,10 @@ rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do 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 @@ -310,19 +310,16 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim _bound_names (ValBindsIn mbinds sigs) = do +rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do -- rename the sigs env <- getGblEnv traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env)) - sigs' <- rename_sigs sigs + 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) @@ -677,41 +674,26 @@ rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) \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' } +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' } ---------------------- -rename_sigs :: [LSig RdrName] -> RnM [LSig Name] -rename_sigs sigs = mapM (wrapLocM renameSig) 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 - _ -> 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 #-} @@ -720,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} @@ -833,7 +863,7 @@ rnGRHS' ctxt (GRHS guards rhs) %************************************************************************ \begin{code} -dupSigDeclErr :: [LSig Name] -> RnM () +dupSigDeclErr :: [LSig RdrName] -> RnM () dupSigDeclErr sigs@(L loc sig : _) = addErrAt loc $ vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon, @@ -843,22 +873,10 @@ dupSigDeclErr sigs@(L loc sig : _) ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig dupSigDeclErr [] = panic "dupSigDeclErr" -unknownSigErr :: LSig Name -> RnM () +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 _ _ = empty + = addErrAt loc $ + sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] methodBindErr :: HsBindLR RdrName RdrName -> SDoc methodBindErr mbind diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index ae1966c..4d2ee53 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -11,7 +11,7 @@ module RnEnv ( lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, + lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -215,35 +215,6 @@ lookupTopBndrRn_maybe rdr_name Nothing -> returnM Nothing Just gre -> returnM (Just $ gre_name gre) } --- lookupLocatedSigOccRn 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". -lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do - { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of { - Just n -> return n ; - Nothing -> do - { mb_gre <- lookupGreLocalRn rdr_name - ; case mb_gre of - Just gre -> return (gre_name gre) - Nothing -> lookupGlobalOccRn rdr_name - }}} ----------------------------------------------- lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index c7b2368..b64782d 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -427,9 +427,10 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- But the (unqualified) method names are in scope let binders = collectHsBindBinders mbinds' - ok_sig = okInstDclSig (mkNameSet binders) + bndr_set = mkNameSet binders in - bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> + bindLocalNames binders + (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' -> returnM (InstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` at_fvs @@ -731,7 +732,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds ; (ats', ats_fvs) <- rnATs ats - ; sigs' <- renameSigs okClsDclSig sigs + ; sigs' <- renameSigs Nothing okClsDclSig sigs ; return (tyvars', context', fds', ats', ats_fvs, sigs') } -- No need to check for duplicate associated type decls -- 1.7.10.4