summaryrefslogtreecommitdiff
path: root/compiler/rename/RnBinds.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename/RnBinds.hs')
-rw-r--r--compiler/rename/RnBinds.hs150
1 files changed, 76 insertions, 74 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 7f0490a68e..5d6d037e6e 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -170,12 +171,13 @@ it expects the global environment to contain bindings for the binders
-- for top-level bindings, we need to make top-level names,
-- so we have a different entry point than for local bindings
rnTopBindsLHS :: MiniFixityEnv
- -> HsValBinds RdrName
- -> RnM (HsValBindsLR Name RdrName)
+ -> HsValBinds GhcPs
+ -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS fix_env binds
= rnValBindsLHS (topRecNameMaker fix_env) binds
-rnTopBindsBoot :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
+rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
+ -> RnM (HsValBinds GhcRn, DefUses)
-- A hs-boot file has no bindings.
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot bound_names (ValBindsIn mbinds sigs)
@@ -192,9 +194,9 @@ rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
*********************************************************
-}
-rnLocalBindsAndThen :: HsLocalBinds RdrName
- -> (HsLocalBinds Name -> FreeVars -> RnM (result, FreeVars))
- -> RnM (result, FreeVars)
+rnLocalBindsAndThen :: HsLocalBinds GhcPs
+ -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
-- This version (a) assumes that the binding vars are *not* already in scope
-- (b) removes the binders from the free vars of the thing inside
-- The parser doesn't produce ThenBinds
@@ -210,12 +212,12 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
(thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds
return (thing, fvs_thing `plusFV` fv_binds)
-rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
+rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
(ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
-rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
+rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
rnIPBind (IPBind ~(Left n) expr) = do
(expr',fvExpr) <- rnLExpr expr
return (IPBind (Left n) expr', fvExpr)
@@ -231,8 +233,8 @@ rnIPBind (IPBind ~(Left n) expr) = do
-- Renaming local binding groups
-- Does duplicate/shadow check
rnLocalValBindsLHS :: MiniFixityEnv
- -> HsValBinds RdrName
- -> RnM ([Name], HsValBindsLR Name RdrName)
+ -> HsValBinds GhcPs
+ -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS fix_env binds
= do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
@@ -267,8 +269,8 @@ rnLocalValBindsLHS fix_env binds
-- 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
rnValBindsLHS :: NameMaker
- -> HsValBinds RdrName
- -> RnM (HsValBindsLR Name RdrName)
+ -> HsValBinds GhcPs
+ -> RnM (HsValBindsLR GhcRn GhcPs)
rnValBindsLHS topP (ValBindsIn mbinds sigs)
= do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
; return $ ValBindsIn mbinds' sigs }
@@ -283,8 +285,8 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
--
-- Does not bind the local fixity declarations
rnValBindsRHS :: HsSigCtxt
- -> HsValBindsLR Name RdrName
- -> RnM (HsValBinds Name, DefUses)
+ -> HsValBindsLR GhcRn GhcPs
+ -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
= do { (sigs', sig_fvs) <- renameSigs ctxt sigs
@@ -317,8 +319,8 @@ rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
--
-- The client is also responsible for bringing the fixities into scope
rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
- -> HsValBindsLR Name RdrName
- -> RnM (HsValBinds Name, DefUses)
+ -> HsValBindsLR GhcRn GhcPs
+ -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS bound_names binds
= rnValBindsRHS (LocalBindCtxt bound_names) binds
@@ -328,8 +330,8 @@ rnLocalValBindsRHS bound_names binds
-- here there are no local fixity decls passed in;
-- the local fixity decls come from the ValBinds sigs
rnLocalValBindsAndThen
- :: HsValBinds RdrName
- -> (HsValBinds Name -> FreeVars -> RnM (result, FreeVars))
+ :: HsValBinds GhcPs
+ -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
= do { -- (A) Create the local fixity environment
@@ -390,11 +392,11 @@ rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
rnBindLHS :: NameMaker
-> SDoc
- -> HsBind RdrName
+ -> HsBind GhcPs
-- returns the renamed left-hand side,
-- and the FreeVars *of the LHS*
-- (i.e., any free variables of the pattern)
- -> RnM (HsBindLR Name RdrName)
+ -> RnM (HsBindLR GhcRn GhcPs)
rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
= do
@@ -429,18 +431,18 @@ rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
-rnLBind :: (Name -> [Name]) -- Signature tyvar function
- -> LHsBindLR Name RdrName
- -> RnM (LHsBind Name, [Name], Uses)
+rnLBind :: (Name -> [Name]) -- Signature tyvar function
+ -> LHsBindLR GhcRn GhcPs
+ -> RnM (LHsBind GhcRn, [Name], Uses)
rnLBind sig_fn (L loc bind)
= setSrcSpan loc $
do { (bind', bndrs, dus) <- rnBind sig_fn bind
; return (L loc bind', bndrs, dus) }
-- assumes the left-hands-side vars are in scope
-rnBind :: (Name -> [Name]) -- Signature tyvar function
- -> HsBindLR Name RdrName
- -> RnM (HsBind Name, [Name], Uses)
+rnBind :: (Name -> [Name]) -- Signature tyvar function
+ -> HsBindLR GhcRn GhcPs
+ -> RnM (HsBind GhcRn, [Name], Uses)
rnBind _ bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
-- pat fvs were stored in bind_fvs
@@ -542,8 +544,8 @@ trac ticket #1136.
* *
********************************************************************* -}
-depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
- -> ([(RecFlag, LHsBinds Name)], DefUses)
+depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)
+ -> ([(RecFlag, LHsBinds GhcRn)], DefUses)
-- Dependency analysis; this is important so that
-- unused-binding reporting is accurate
depAnalBinds binds_w_dus
@@ -577,14 +579,14 @@ depAnalBinds binds_w_dus
-- (x,y) = e
-- In e, 'a' will be in scope, and it'll be the one from 'y'!
-mkSigTvFn :: [LSig Name] -> (Name -> [Name])
+mkSigTvFn :: [LSig GhcRn] -> (Name -> [Name])
-- Return a lookup function that maps an Id Name to the names
-- of the type variables that should scope over its body.
mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
where
env = mkHsSigEnv get_scoped_tvs sigs
- get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name])
+ get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
-- Returns (binders, scoped tvs for those binders)
get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))
= Just (names, hsScopedTvs sig_ty)
@@ -601,7 +603,7 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
-- Note: for local fixity declarations, duplicates would also be checked in
-- check_sigs below. But we also use this function at the top level.
-makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
+makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
@@ -637,9 +639,9 @@ dupFixityDecl loc rdr_name
* *
********************************************************************* -}
-rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function
- -> PatSynBind Name RdrName
- -> RnM (PatSynBind Name Name, [Name], Uses)
+rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function
+ -> PatSynBind GhcRn GhcPs
+ -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)
rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
, psb_args = details
, psb_def = pat
@@ -809,9 +811,9 @@ a binder.
rnMethodBinds :: Bool -- True <=> is a class declaration
-> Name -- Class name
-> [Name] -- Type variables from the class/instance header
- -> LHsBinds RdrName -- Binds
- -> [LSig RdrName] -- and signatures/pragmas
- -> RnM (LHsBinds Name, [LSig Name], FreeVars)
+ -> LHsBinds GhcPs -- Binds
+ -> [LSig GhcPs] -- and signatures/pragmas
+ -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
-- Used for
-- * the default method bindings in a class decl
-- * the method bindings in an instance decl
@@ -864,9 +866,9 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
| otherwise = thing_inside
rnMethodBindLHS :: Bool -> Name
- -> LHsBindLR RdrName RdrName
- -> LHsBindsLR Name RdrName
- -> RnM (LHsBindsLR Name RdrName)
+ -> LHsBindLR GhcPs GhcPs
+ -> LHsBindsLR GhcRn GhcPs
+ -> RnM (LHsBindsLR GhcRn GhcPs)
rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
= setSrcSpan loc $ do
do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
@@ -910,8 +912,8 @@ signatures. We'd only need this if we wanted to report unused tyvars.
-}
renameSigs :: HsSigCtxt
- -> [LSig RdrName]
- -> RnM ([LSig Name], FreeVars)
+ -> [LSig GhcPs]
+ -> RnM ([LSig GhcRn], FreeVars)
-- Renames the signatures and performs error checks
renameSigs ctxt sigs
= do { mapM_ dupSigDeclErr (findDupSigs sigs)
@@ -935,7 +937,7 @@ renameSigs ctxt sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
+renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
-- FixitySig is renamed elsewhere.
renameSig _ (IdSig x)
= return (IdSig x, emptyFVs) -- Actually this never occurs
@@ -1089,7 +1091,7 @@ okHsSig ctxt (L _ sig)
(CompleteMatchSig {}, _) -> False
-------------------
-findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
+findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]]
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
@@ -1119,7 +1121,7 @@ findDupSigs sigs
mtch _ _ = False
-- Warn about multiple MINIMAL signatures
-checkDupMinimalSigs :: [LSig RdrName] -> RnM ()
+checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
checkDupMinimalSigs sigs
= case filter isMinimalLSig sigs of
minSigs@(_:_:_) -> dupMinimalSigErr minSigs
@@ -1133,26 +1135,26 @@ checkDupMinimalSigs sigs
************************************************************************
-}
-rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
- -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
- -> MatchGroup RdrName (Located (body RdrName))
- -> RnM (MatchGroup Name (Located (body Name)), FreeVars)
+rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ -> MatchGroup GhcPs (Located (body GhcPs))
+ -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
= do { empty_case_ok <- xoptM LangExt.EmptyCase
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin new_ms, ms_fvs) }
-rnMatch :: Outputable (body RdrName) => HsMatchContext Name
- -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
- -> LMatch RdrName (Located (body RdrName))
- -> RnM (LMatch Name (Located (body Name)), FreeVars)
+rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ -> LMatch GhcPs (Located (body GhcPs))
+ -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
-rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
- -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
- -> Match RdrName (Located (body RdrName))
- -> RnM (Match Name (Located (body Name)), FreeVars)
+rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ -> Match GhcPs (Located (body GhcPs))
+ -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
, m_type = maybe_rhs_sig, m_grhss = grhss })
= do { -- Result type signatures are no longer supported
@@ -1183,7 +1185,7 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
resSigErr :: Outputable body
- => Match RdrName body -> HsType RdrName -> SDoc
+ => Match GhcPs body -> HsType GhcPs -> SDoc
resSigErr match ty
= vcat [ text "Illegal result type signature" <+> quotes (ppr ty)
, nest 2 $ ptext (sLit
@@ -1199,24 +1201,24 @@ resSigErr match ty
-}
rnGRHSs :: HsMatchContext Name
- -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
- -> GRHSs RdrName (Located (body RdrName))
- -> RnM (GRHSs Name (Located (body Name)), FreeVars)
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ -> GRHSs GhcPs (Located (body GhcPs))
+ -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
rnGRHSs ctxt rnBody (GRHSs grhss (L l binds))
= rnLocalBindsAndThen binds $ \ binds' _ -> do
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
return (GRHSs grhss' (L l binds'), fvGRHSs)
rnGRHS :: HsMatchContext Name
- -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
- -> LGRHS RdrName (Located (body RdrName))
- -> RnM (LGRHS Name (Located (body Name)), FreeVars)
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ -> LGRHS GhcPs (Located (body GhcPs))
+ -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
rnGRHS' :: HsMatchContext Name
- -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
- -> GRHS RdrName (Located (body RdrName))
- -> RnM (GRHS Name (Located (body Name)), FreeVars)
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ -> GRHS GhcPs (Located (body GhcPs))
+ -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
rnGRHS' ctxt rnBody (GRHS guards rhs)
= do { pattern_guards_allowed <- xoptM LangExt.PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
@@ -1242,7 +1244,7 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
************************************************************************
-}
-dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM ()
+dupSigDeclErr :: [(Located RdrName, Sig GhcPs)] -> RnM ()
dupSigDeclErr pairs@((L loc name, sig) : _)
= addErrAt loc $
vcat [ text "Duplicate" <+> what_it_is
@@ -1253,32 +1255,32 @@ dupSigDeclErr pairs@((L loc name, sig) : _)
dupSigDeclErr [] = panic "dupSigDeclErr"
-misplacedSigErr :: LSig Name -> RnM ()
+misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr (L loc sig)
= addErrAt loc $
sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
-defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr :: Sig GhcPs -> SDoc
defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
2 (ppr sig)
, text "Use DefaultSignatures to enable default signatures" ]
-bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
+bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
bindsInHsBootFile mbinds
= hang (text "Bindings in hs-boot files are not allowed")
2 (ppr mbinds)
-nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc
+nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc
nonStdGuardErr guards
= hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
4 (interpp'SP guards)
-unusedPatBindWarn :: HsBind Name -> SDoc
+unusedPatBindWarn :: HsBind GhcRn -> SDoc
unusedPatBindWarn bind
= hang (text "This pattern-binding binds no variables:")
2 (ppr bind)
-dupMinimalSigErr :: [LSig RdrName] -> RnM ()
+dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
dupMinimalSigErr sigs@(L loc _ : _)
= addErrAt loc $
vcat [ text "Multiple minimal complete definitions"
View Lorry Controller Status