they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings
rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings
rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv, MiniFixityEnv
) where
-#include "HsVersions.h"
-
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import RnEnv
import DynFlags ( DynFlag(..) )
-import HscTypes (FixItem(..))
import Name
import NameEnv
-import LazyUniqFM
import NameSet
import PrelNames ( isUnboundName )
import RdrName ( RdrName, rdrNameOcc )
-import SrcLoc ( Located(..), unLoc, noLoc )
+import SrcLoc
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..), stronglyConnComp )
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
; sigs' <- renameSigs okHsBootSig sigs
; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
+rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
\end{code}
(thing, fvs_thing) <- thing_inside (HsIPBinds binds')
return (thing, fvs_thing `plusFV` fv_binds)
-
+rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
(ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s)
+rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
rnIPBind (IPBind n expr) = do
name <- newIPNameRn n
(expr',fvExpr) <- rnLExpr expr
-> SDoc -- doc string for dup names and shadowing
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs) = do
+rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do
-- rename the LHSes
mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
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
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
-rnValBindsRHSGen trim bound_names binds@(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))
+ traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env))
sigs' <- rename_sigs sigs
-- rename the RHSes
binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
check_sigs (okBindSig (duDefs anal_dus)) sigs'
return (valbind', valbind'_dus)
+rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
+
-- Wrapper for local binds
--
-- The *client* of this function is responsible for checking for unused binders;
; return (result, all_uses) }}
-- The bound names are pruned out of all_uses
-- by the bindLocalNamesFV call above
-
+
+rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs)
-- Process the fixity declarations, making a FastString -> (Located Fixity) map
; return env}
}
-pprFixEnv :: NameEnv FixItem -> SDoc
-pprFixEnv env
- = pprWithCommas (\ (FixItem n f) -> ppr f <+> ppr n)
- (nameEnvElts env)
-
+dupFixityDecl :: SrcSpan -> RdrName -> SDoc
dupFixityDecl loc rdr_name
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("also at ") <+> ppr loc]
+ = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext (sLit "also at ") <+> ppr loc]
---------------------
-- (i.e., any free variables of the pattern)
-> RnM (LHsBindLR Name RdrName)
-rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat,
- pat_rhs = grhss,
- bind_fvs=bind_fvs,
- pat_rhs_ty=pat_rhs_ty
- }))
+rnBindLHS name_maker _ (L loc (PatBind { pat_lhs = pat,
+ pat_rhs = grhss,
+ pat_rhs_ty=pat_rhs_ty
+ }))
= setSrcSpan loc $ do
-- we don't actually use the FV processing of rnPatsAndThen here
(pat',pat'_fvs) <- rnBindPat name_maker pat
-- when we rename the RHS
pat_rhs_ty = pat_rhs_ty }))
-rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _),
- fun_infix = inf,
- fun_matches = matches,
- fun_co_fn = fun_co_fn,
- bind_fvs = bind_fvs,
- fun_tick = fun_tick
- }))
+rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _),
+ fun_infix = inf,
+ fun_matches = matches,
+ fun_co_fn = fun_co_fn,
+ fun_tick = fun_tick
+ }))
= setSrcSpan loc $
do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
return (newname, emptyFVs)
fun_tick = fun_tick
})) }
+rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
+
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
-> (FreeVars -> FreeVars) -- Trimming function for rhs free vars
-> LHsBindLR Name RdrName
-> RnM (LHsBind Name, [Name], Uses)
-rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat,
- pat_rhs = grhss,
- -- pat fvs were stored here while processing the LHS
- bind_fvs=pat_fvs }))
+rnBind _ trim (L loc (PatBind { pat_lhs = pat,
+ pat_rhs = grhss,
+ -- pat fvs were stored here while
+ -- processing the LHS
+ bind_fvs=pat_fvs }))
= setSrcSpan loc $
do {let bndrs = collectPatBinders pat
fun_tick = Nothing }),
[plain_name], fvs)
}
+
+rnBind _ _ b = pprPanic "rnBind" (ppr b)
---------------------
depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
, bndr <- bndrs ]
get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
- get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus])
+ get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
get_du (CyclicSCC binds_w_dus) = (Just defs, uses)
(bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
return (bind' `unionBags` binds, fvs_bind `plusFV` fvs)
+rnMethodBind :: Name
+ -> (Name -> [Name])
+ -> [Name]
+ -> LHsBindLR RdrName RdrName
+ -> RnM (Bag (LHsBindLR Name Name), FreeVars)
rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf,
fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $ do
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do
+rnMethodBind _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do
addLocErr mbind methodBindErr
return (emptyBag, emptyFVs)
+
+rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
sigs' = filterOut bad_name sigs
bad_name sig = case sigName sig of
Just n -> isUnboundName n
- other -> False
+ _ -> False
-- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
-rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
+rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars)
+rnMatch' ctxt (Match pats maybe_rhs_sig grhss)
=
-- Deal with the rhs type signature
bindPatSigTyVarsFV rhs_sig_tys $ do
rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
+rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs)
= do { pattern_guards_allowed <- doptM Opt_PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
-- Glasgow extension
is_standard_guard [] = True
is_standard_guard [L _ (ExprStmt _ _ _)] = True
- is_standard_guard other = False
+ is_standard_guard _ = False
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+dupSigDeclErr :: [LSig Name] -> RnM ()
dupSigDeclErr sigs@(L loc sig : _)
= addErrAt loc $
- vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon,
+ vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon,
nest 2 (vcat (map ppr_sig sigs))]
where
what_it_is = hsSigDoc sig
ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
+dupSigDeclErr [] = panic "dupSigDeclErr"
+unknownSigErr :: LSig Name -> RnM ()
unknownSigErr (L loc sig)
= do { mod <- getModule
; addErrAt loc $
- vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig],
+ 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")
+ = 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")
+ = ptext (sLit "You cannot give a type signature for an imported value")
- extra_stuff mod other = empty
+ extra_stuff _ _ = empty
+methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
- = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
+ = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
2 (ppr mbind)
+bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
bindsInHsBootFile mbinds
- = hang (ptext SLIT("Bindings in hs-boot files are not allowed"))
+ = hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
2 (ppr mbinds)
+nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
nonStdGuardErr guards
- = hang (ptext SLIT("accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
+ = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
4 (interpp'SP guards)
\end{code}
projects / ghc-hetmet.git / blobdiff