X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=13035e72e2831185bc58ee74c632c381ac49b151;hb=876b4ef2093cb9c104db33c7db1200b941b6d079;hp=1b464540503283b63c03b75b857f0dcacd3f6d8f;hpb=e3a4d6c36802d9395b40af1d9fb24cbd7ce2f720;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 1b46454..13035e7 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -44,7 +44,8 @@ import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Bag import Outputable -import Maybes ( orElse, fromJust, isJust ) +import Maybes ( orElse, isJust ) +import Util ( filterOut ) import Monad ( foldM ) \end{code} @@ -174,20 +175,15 @@ rnTopBindsBoot :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; sigs' <- renameSigs okHsBootSig sigs - ; return (ValBindsIn emptyLHsBinds sigs', usesOnly (hsSigsFVs sigs')) } + ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsSrc binds@(ValBindsIn mbinds _) - = bindPatSigTyVars (collectSigTysFromHsBinds mbinds) $ \ _ -> - -- Hmm; by analogy with Ids, this doesn't look right - -- Top-level bound type vars should really scope over - -- everything, but we only scope them over the other bindings - - do { (binds', dus) <- rnValBinds noTrim binds + = do { (binds', dus) <- rnValBinds noTrim binds -- Warn about missing signatures, ; let { ValBindsOut _ sigs' = binds' - ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs'] + ; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs'] ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars } ; warn_missing_sigs <- doptM Opt_WarnMissingSigs @@ -254,7 +250,6 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside -- current scope, inventing new names for the new binders -- This also checks that the names form a set bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs -> - bindPatSigTyVarsFV (collectSigTysFromHsBinds mbinds) $ -- Then install local fixity declarations -- Notice that they scope over thing_inside too @@ -300,6 +295,8 @@ rnValBinds trim (ValBindsIn mbinds sigs) ; let (binds', bind_dus) = depAnalBinds binds_w_dus + -- We do the check-sigs after renaming the bindings, + -- so that we have convenient access to the binders ; check_sigs (okBindSig (duDefs bind_dus)) sigs' ; return (ValBindsOut binds' sigs', @@ -309,8 +306,8 @@ rnValBinds trim (ValBindsIn mbinds sigs) --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) --- Dependency analysis; this is important so that unused-binding --- reporting is accurate +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) where @@ -318,9 +315,8 @@ depAnalBinds binds_w_dus keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..] - edges = [ (node, key, [fromJust mb_key | n <- nameSetToList uses, - let mb_key = lookupNameEnv key_map n, - isJust mb_key ]) + edges = [ (node, key, [key | n <- nameSetToList uses, + Just key <- [lookupNameEnv key_map n] ]) | (node@(_,_,uses), key) <- keyd_nodes ] key_map :: NameEnv Int -- Which binding it comes from @@ -358,8 +354,8 @@ mkSigTvFn sigs where env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs) - | L _ (Sig (L _ name) - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + | L _ (TypeSig (L _ name) + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all @@ -377,7 +373,7 @@ rnBind :: (Name -> [Name]) -- Signature tyvar function -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars -> LHsBind RdrName -> RnM (LHsBind Name, [Name], Uses) -rnBind sig_fn trim (L loc (PatBind pat grhss ty _)) +rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss })) = setSrcSpan loc $ do { (pat', pat_fvs) <- rnLPat pat @@ -386,9 +382,11 @@ rnBind sig_fn trim (L loc (PatBind pat grhss ty _)) ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $ rnGRHSs PatBindRhs grhss - ; return (L loc (PatBind pat' grhss' ty (trim fvs)), bndrs, pat_fvs `plusFV` fvs) } + ; return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss', + pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }), + bndrs, pat_fvs `plusFV` fvs) } -rnBind sig_fn trim (L loc (FunBind name inf matches _)) +rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches })) = setSrcSpan loc $ do { new_name <- lookupLocatedBndrRn name ; let plain_name = unLoc new_name @@ -398,7 +396,9 @@ rnBind sig_fn trim (L loc (FunBind name inf matches _)) ; checkPrecMatch inf plain_name matches' - ; return (L loc (FunBind new_name inf matches' (trim fvs)), [plain_name], fvs) + ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches', + bind_fvs = trim fvs, fun_co_fn = idCoercion }), + [plain_name], fvs) } \end{code} @@ -430,7 +430,8 @@ rnMethodBinds cls gen_tyvars binds (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) -rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _)) +rnMethodBind cls gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, + fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> let plain_name = unLoc sel_name in @@ -441,7 +442,9 @@ rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _)) new_group = MatchGroup new_matches placeHolderType in checkPrecMatch inf plain_name new_group `thenM_` - returnM (unitBag (L loc (FunBind sel_name inf new_group fvs)), fvs `addOneFV` plain_name) + returnM (unitBag (L loc (FunBind { fun_id = sel_name, fun_infix = inf, fun_matches = new_group, + bind_fvs = fvs, fun_co_fn = idCoercion })), + fvs `addOneFV` plain_name) -- The 'fvs' field isn't used for method binds where -- Truly gruesome; bring into scope the correct members of the generic @@ -499,15 +502,14 @@ check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () check_sigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - = do { mappM_ unknownSigErr sigs' + = do { mappM_ unknownSigErr (filter (not . ok_sig) sigs') ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') } where -- Don't complain about an unbound name again - sigs' = filter bad sigs - bad sig = not (ok_sig sig) && - case sigName sig of - Just n | isUnboundName n -> False - other -> True + 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 -- because this won't work for: @@ -520,23 +522,23 @@ check_sigs ok_sig sigs renameSig :: Sig RdrName -> RnM (Sig Name) -- FixitSig is renamed elsewhere. -renameSig (Sig v ty) +renameSig (TypeSig v ty) = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (Sig new_v new_ty) + returnM (TypeSig new_v new_ty) renameSig (SpecInstSig ty) = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> returnM (SpecInstSig new_ty) -renameSig (SpecSig v ty) +renameSig (SpecSig v ty inl) = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (SpecSig new_v new_ty) + returnM (SpecSig new_v new_ty inl) -renameSig (InlineSig b v p) +renameSig (InlineSig v s) = lookupLocatedSigOccRn v `thenM` \ new_v -> - returnM (InlineSig b new_v p) + returnM (InlineSig new_v s) \end{code} @@ -601,11 +603,12 @@ rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) rnGRHS' ctxt (GRHS guards rhs) = do { opt_GlasgowExts <- doptM Opt_GlasgowExts - ; checkM (opt_GlasgowExts || is_standard_guard guards) - (addWarn (nonStdGuardErr guards)) - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ rnLExpr rhs + + ; checkM (opt_GlasgowExts || is_standard_guard guards') + (addWarn (nonStdGuardErr guards')) + ; return (GRHS guards' rhs', fvs) } where -- Standard Haskell 1.4 guards are just a single boolean @@ -651,8 +654,7 @@ bindsInHsBootFile mbinds = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) -nonStdGuardErr guard - = hang (ptext - SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") - ) 4 (ppr guard) +nonStdGuardErr guards + = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) + 4 (interpp'SP guards) \end{code}