summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/HsUtils.hs29
-rw-r--r--compiler/rename/RnBinds.hs31
-rw-r--r--compiler/typecheck/TcClassDcl.hs36
-rw-r--r--compiler/typecheck/TcInstDcls.hs6
-rw-r--r--testsuite/tests/rename/should_compile/T12533.hs10
-rw-r--r--testsuite/tests/rename/should_compile/all.T1
6 files changed, 78 insertions, 35 deletions
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 6d1f15fd38..641aac16f7 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -54,7 +54,7 @@ module HsUtils(
-- Types
mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
- mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
+ mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts
@@ -106,6 +106,7 @@ import TcType
import DataCon
import Name
import NameSet
+import NameEnv
import BasicTypes
import SrcLoc
import FastString
@@ -566,6 +567,32 @@ mkLHsSigType ty = mkHsImplicitBndrs ty
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
+mkHsSigEnv :: forall a. (LSig Name -> Maybe ([Located Name], a))
+ -> [LSig Name]
+ -> NameEnv a
+mkHsSigEnv get_info sigs
+ = mkNameEnv (mk_pairs ordinary_sigs)
+ `extendNameEnvList` (mk_pairs gen_dm_sigs)
+ -- The subtlety is this: in a class decl with a
+ -- default-method signature as well as a method signature
+ -- we want the latter to win (Trac #12533)
+ -- class C x where
+ -- op :: forall a . x a -> x a
+ -- default op :: forall b . x b -> x b
+ -- op x = ...(e :: b -> b)...
+ -- The scoped type variables of the 'default op', namely 'b',
+ -- scope over the code for op. The 'forall a' does not!
+ -- This applies both in the renamer and typechecker, both
+ -- of which use this function
+ where
+ (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
+ is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
+ is_gen_dm_sig _ = False
+
+ mk_pairs :: [LSig Name] -> [(Name, a)]
+ mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
+ , L _ n <- ns ]
+
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig
-- The former is what is parsed, but the latter is
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index a965a65e63..4af699a274 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -547,24 +549,19 @@ depAnalBinds binds_w_dus
mkSigTvFn :: [LSig Name] -> (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` []
+mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
where
- env :: NameEnv [Name]
- env = foldr add_scoped_sig emptyNameEnv sigs
-
- add_scoped_sig :: LSig Name -> NameEnv [Name] -> NameEnv [Name]
- add_scoped_sig (L _ (ClassOpSig _ names sig_ty)) env
- = add_scoped_tvs names (hsScopedTvs sig_ty) env
- add_scoped_sig (L _ (TypeSig names sig_ty)) env
- = add_scoped_tvs names (hsWcScopedTvs sig_ty) env
- add_scoped_sig (L _ (PatSynSig names sig_ty)) env
- = add_scoped_tvs names (hsScopedTvs sig_ty) env
- add_scoped_sig _ env = env
-
- add_scoped_tvs :: [Located Name] -> [Name] -> NameEnv [Name] -> NameEnv [Name]
- add_scoped_tvs id_names tv_names env
- = foldr (\(L _ id_n) env -> extendNameEnv env id_n tv_names) env id_names
+ env = mkHsSigEnv get_scoped_tvs sigs
+
+ get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name])
+ -- Returns (binders, scoped tvs for those binders)
+ get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))
+ = Just (names, hsScopedTvs sig_ty)
+ get_scoped_tvs (L _ (TypeSig names sig_ty))
+ = Just (names, hsWcScopedTvs sig_ty)
+ get_scoped_tvs (L _ (PatSynSig names sig_ty))
+ = Just (names, hsScopedTvs sig_ty)
+ get_scoped_tvs _ = Nothing
-- Process the fixity declarations, making a FastString -> (Located Fixity) map
-- (We keep the location around for reporting duplicate fixity declarations.)
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index bc26055d45..aa5e1c41b9 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -11,7 +11,7 @@ Typechecking class declarations
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod,
tcClassMinimalDef,
- HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
+ HsSigFun, mkHsSigFun,
tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
tcATDefault
) where
@@ -134,8 +134,8 @@ tcClassSigs clas sigs def_methods
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
- | nm `elem` dm_bind_names = Just VanillaDM
- | otherwise = Nothing
+ | nm `elem` dm_bind_names = Just VanillaDM
+ | otherwise = Nothing
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
@@ -200,7 +200,17 @@ tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
(sel_id, Just (dm_name, dm_spec))
| Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
- = do { -- First look up the default method -- It should be there!
+ = do { -- First look up the default method; it should be there!
+ -- It can be the orinary default method
+ -- or the generic-default method. E.g of the latter
+ -- class C a where
+ -- op :: a -> a -> Bool
+ -- default op :: Eq a => a -> a -> Bool
+ -- op x y = x==y
+ -- The default method we generate is
+ -- $gm :: (C a, Eq a) => a -> a -> Bool
+ -- $gm x y = x==y
+
global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags
; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
@@ -214,7 +224,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
(text "Ignoring SPECIALISE pragmas on default method"
<+> quotes (ppr sel_name))
- ; let hs_ty = lookupHsSig hs_sig_fn sel_name
+ ; let hs_ty = hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
-- We need the HsType so that we can bring the right
-- type variables into scope
@@ -311,18 +321,16 @@ instantiateMethod clas sel_id inst_tys
---------------------------
-type HsSigFun = NameEnv (LHsSigType Name)
-
-emptyHsSigs :: HsSigFun
-emptyHsSigs = emptyNameEnv
+type HsSigFun = Name -> Maybe (LHsSigType Name)
mkHsSigFun :: [LSig Name] -> HsSigFun
-mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
- | L _ (ClassOpSig False ns hs_ty) <- sigs
- , L _ n <- ns ]
+mkHsSigFun sigs = lookupNameEnv env
+ where
+ env = mkHsSigEnv get_classop_sig sigs
-lookupHsSig :: HsSigFun -> Name -> Maybe (LHsSigType Name)
-lookupHsSig = lookupNameEnv
+ get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name)
+ get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty)
+ get_classop_sig _ = Nothing
---------------------------
findMethodBind :: Name -- Selector
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 220923d34d..96d7493f79 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -16,7 +16,7 @@ import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl( tcClassDecl2, tcATDefault,
- HsSigFun, lookupHsSig, mkHsSigFun,
+ HsSigFun, mkHsSigFun,
findMethodBind, instantiateMethod )
import TcSigs
import TcRnMonad
@@ -1349,8 +1349,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
tcMethodBodyHelp :: HsSigFun -> Id -> TcId
-> LHsBind Name -> TcM (LHsBinds TcId)
-tcMethodBodyHelp sig_fn sel_id local_meth_id meth_bind
- | Just hs_sig_ty <- lookupHsSig sig_fn sel_name
+tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
+ | Just hs_sig_ty <- hs_sig_fn sel_name
-- There is a signature in the instance
-- See Note [Instance method signatures]
= do { let ctxt = FunSigCtxt sel_name True
diff --git a/testsuite/tests/rename/should_compile/T12533.hs b/testsuite/tests/rename/should_compile/T12533.hs
new file mode 100644
index 0000000000..a120babf3f
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T12533.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ScopedTypeVariables, DefaultSignatures #-}
+
+module T12533 where
+
+class Foo x where
+ foo :: forall a . x a -> x a
+ default foo :: forall a . x a -> x a
+ foo x = go
+ where go :: x a
+ go = undefined
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 90b1d605bc..b6318aeeed 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -242,3 +242,4 @@ test('T12127',
[extra_clean(['T12127a.hi', 'T12127a.o'])],
multimod_compile,
['T12127', '-v0'])
+test('T12533', normal, compile, [''])
View Lorry Controller Status