X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=13035e72e2831185bc58ee74c632c381ac49b151;hb=876b4ef2093cb9c104db33c7db1200b941b6d079;hp=f067e5d5d323936db7aad92d57e8a276e8569ced;hpb=22df1e2a699d6eda6d5ada5073bc97c9f35e2947;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index f067e5d..13035e7 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -44,7 +44,7 @@ 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} @@ -179,16 +179,11 @@ rnTopBindsBoot (ValBindsIn mbinds 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 @@ -255,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 @@ -321,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 @@ -361,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 @@ -380,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 @@ -389,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 @@ -401,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} @@ -433,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 @@ -444,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 @@ -522,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} @@ -603,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 @@ -653,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}