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}
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
-- 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
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
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
-> (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
; (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
; 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}
(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
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
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}
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
= 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}
projects / ghc-hetmet.git / blobdiff