X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=4899adb07773e2c7c2c51649af3b2fdb51c30ef8;hp=b76e6db95e7cdf038455e3511592c9974da9967d;hb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44;hpb=861e1d55126391785e93493080d3c7516812675e diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index b76e6db..4899adb 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,11 +9,18 @@ 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} -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, MiniFixityEnv +module RnBinds ( + -- Renaming top-level bindings + rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, mkSigTvFn, + rnMatchGroup, rnGRHSs, + makeMiniFixityEnv, MiniFixityEnv, + misplacedSigErr ) where import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) @@ -158,17 +165,17 @@ rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds - = rnValBindsLHSFromDoc (topRecNameMaker fix_env) binds + = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsRHS :: NameSet -- Names bound by these binds - -> HsValBindsLR Name RdrName +rnTopBindsRHS :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBindsRHS bound_names binds = - do { is_boot <- tcIsHsBoot +rnTopBindsRHS binds + = do { is_boot <- tcIsHsBoot ; if is_boot then rnTopBindsBoot binds - else rnValBindsRHSGen (\x -> x) -- don't trim free vars - bound_names binds } + else rnValBindsRHS noTrimFVs -- don't trim free vars + Nothing -- Allow SPEC prags for imports + binds } -- Wrapper if we don't need to do anything in between the left and right, -- or anything else in the scope of the left @@ -176,10 +183,11 @@ rnTopBindsRHS bound_names binds = -- Never used when there are fixity declarations rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBinds b = - do nl <- rnTopBindsLHS emptyFsEnv b - let bound_names = collectHsValBinders nl - bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl +rnTopBinds b + = do { nl <- rnTopBindsLHS emptyFsEnv b + ; let bound_names = collectHsValBinders nl + ; bindLocalNames bound_names $ + rnValBindsRHS noTrimFVs (Just (mkNameSet bound_names)) nl } rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) @@ -193,7 +201,6 @@ rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} - %********************************************************* %* * HsLocalBinds @@ -211,7 +218,7 @@ rnLocalBindsAndThen EmptyLocalBinds thing_inside = thing_inside EmptyLocalBinds rnLocalBindsAndThen (HsValBinds val_binds) thing_inside - = rnValBindsAndThen val_binds $ \ val_binds' -> + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> thing_inside (HsValBinds val_binds') rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do @@ -241,10 +248,10 @@ rnIPBind (IPBind n expr) = do \begin{code} -- Renaming local binding gropus -- Does duplicate/shadow check -rnValBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM ([Name], HsValBindsLR Name RdrName) -rnValBindsLHS fix_env binds +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds RdrName + -> RnM ([Name], HsValBindsLR Name RdrName) +rnLocalValBindsLHS fix_env binds = do { -- Do error checking: we need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once -- with bindLocatedLocals any more. @@ -259,7 +266,7 @@ rnValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds + ; binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds ; let bound_names = collectHsValBinders binds' ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names @@ -268,41 +275,44 @@ rnValBindsLHS fix_env binds -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level -rnValBindsLHSFromDoc :: NameMaker - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) -rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs) +rnValBindsLHS :: NameMaker + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnValBindsLHS topP (ValBindsIn mbinds sigs) = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds ; return $ ValBindsIn mbinds' sigs } where bndrs = collectHsBindsBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs -rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- 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 -rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets +rnValBindsRHS :: (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 - -> NameSet -- Names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) - -rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) - = do { -- rename the sigs - sigs' <- renameSigs (Just bound_names) okBindSig sigs - -- rename the RHSes + -> Maybe NameSet -- Names bound by the LHSes + -- Nothing if expect sigs for imports + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) + +rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs) + = do { sigs' <- renameSigs mb_bound_names okBindSig sigs ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds ; case depAnalBinds binds_w_dus of - (anal_binds, anal_dus) -> do - { let valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus - ; return (valbind', valbind'_dus) }} + (anal_binds, anal_dus) -> return (valbind', valbind'_dus) + where + valbind' = ValBindsOut anal_binds sigs' + valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + } + +rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b) -rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) +noTrimFVs :: FreeVars -> FreeVars +noTrimFVs fvs = fvs -- Wrapper for local binds -- @@ -310,11 +320,11 @@ rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) -- it doesn't (and can't: we don't have the thing inside the binds) happen here -- -- The client is also responsible for bringing the fixities into scope -rnValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) -rnValBindsRHS bound_names binds - = rnValBindsRHSGen trim bound_names binds +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS trim (Just bound_names) binds where trim fvs = intersectNameSet bound_names fvs -- Only keep the names the names from this group @@ -324,22 +334,22 @@ rnValBindsRHS bound_names binds -- -- here there are no local fixity decls passed in; -- the local fixity decls come from the ValBinds sigs -rnValBindsAndThen :: HsValBinds RdrName - -> (HsValBinds Name -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) -rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside +rnLocalValBindsAndThen :: HsValBinds RdrName + -> (HsValBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = do { -- (A) Create the local fixity environment new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope ; bindLocalNamesFV bound_names $ addLocalFixities new_fixities bound_names $ do { -- (C) Do the RHS and thing inside - (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' -- Report unused bindings based on the (accurate) @@ -372,7 +382,7 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside -- The bound names are pruned out of all_uses -- by the bindLocalNamesFV call above -rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs) +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) -- Process the fixity declarations, making a FastString -> (Located Fixity) map @@ -644,16 +654,22 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} 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 + -> (Sig Name -> 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 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' } + = do { mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate + -- Check for duplicates on RdrName version, + -- because renamed version has unboundName for + -- not-in-scope binders, which gives bogus dup-sig errors + + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs + + ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return good_sigs } ---------------------- -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory @@ -678,8 +694,14 @@ renameSig _ (SpecInstSig ty) = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty ; return (SpecInstSig new_ty) } +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike alll other signatures renameSig mb_names sig@(SpecSig v ty inl) - = do { new_v <- lookupSigOccRn mb_names sig v + = do { new_v <- case mb_names of + Just {} -> lookupSigOccRn mb_names sig v + Nothing -> lookupLocatedOccRn v ; new_ty <- rnHsSigType (quotes (ppr v)) ty ; return (SpecSig new_v new_ty inl) } @@ -784,8 +806,8 @@ dupSigDeclErr sigs@(L loc sig : _) ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig dupSigDeclErr [] = panic "dupSigDeclErr" -unknownSigErr :: LSig RdrName -> RnM () -unknownSigErr (L loc sig) +misplacedSigErr :: LSig Name -> RnM () +misplacedSigErr (L loc sig) = addErrAt loc $ sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]