Fix scoping of type variables in instances

This fixes Trac #12531:

   class Foo x where
     foo :: forall a . x a -> x a
     default foo :: forall b . x b -> x b
     foo x = go
       where go :: x b
             go = undefined

We want 'b' to scope over the code for 'foo', but we were
using 'a' instead.

4 files changed, 67 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