Refactor the treatment of lexically-scoped type variables for instance declarations
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 29 Oct 2014 16:54:47 +0000 (16:54 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 4 Nov 2014 10:37:58 +0000 (10:37 +0000)
Previously the univerally-quantified variables of the DFun were also (bizarrely)
used as the lexically-scoped variables of the instance declaration.  So, for example,
the DFun's type could not be alpha-renamed.  This was an odd restriction, which has
bitten me several times.

This patch does the Right Thing, by adding an ib_tyvars field to the
InstBindings record, which captures the lexically scoped variables.
Easy, robust, nice.  (I think this record probably didn't exist originally,
hence the hack.)

compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcInstDcls.lhs

index 53ca7f0..6b81c29 100644 (file)
@@ -475,21 +475,19 @@ renameDeriv is_boot inst_infos bagBinds
       inst_info@(InstInfo { iSpec = inst
                           , iBinds = InstBindings
                             { ib_binds = binds
+                            , ib_tyvars = tyvars
                             , ib_pragmas = sigs
-                            , ib_extensions = exts -- only for type-checking
+                            , ib_extensions = exts -- Only for type-checking
                             , ib_derived = sa } })
-        =       -- Bring the right type variables into
-                -- scope (yuk), and rename the method binds
-           ASSERT( null sigs )
-           bindLocalNamesFV (map Var.varName tyvars) $
+        =  ASSERT( null sigs )
+           bindLocalNamesFV tyvars $
            do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
               ; let binds' = InstBindings { ib_binds = rn_binds
-                                           , ib_pragmas = []
-                                           , ib_extensions = exts
-                                           , ib_derived = sa }
+                                          , ib_tyvars = tyvars
+                                          , ib_pragmas = []
+                                          , ib_extensions = exts
+                                          , ib_derived = sa }
               ; return (inst_info { iBinds = binds' }, fvs) }
-        where
-          (tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
 \end{code}
 
 Note [Newtype deriving and unused constructors]
@@ -1995,6 +1993,7 @@ genInst comauxs
                     { iSpec   = inst_spec
                     , iBinds  = InstBindings
                         { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
+                        , ib_tyvars = map Var.varName tvs   -- Scope over bindings
                         , ib_pragmas = []
                         , ib_extensions = [ Opt_ImpredicativeTypes
                                           , Opt_RankNTypes ]
@@ -2012,6 +2011,7 @@ genInst comauxs
        ; let inst_info = InstInfo { iSpec   = inst_spec
                                   , iBinds  = InstBindings
                                                 { ib_binds = meth_binds
+                                                , ib_tyvars = map Var.varName tvs
                                                 , ib_pragmas = []
                                                 , ib_extensions = []
                                                 , ib_derived = True } }
index 7d54969..bcd6bfd 100644 (file)
@@ -723,10 +723,15 @@ iDFunId info = instanceDFunId (iSpec info)
 
 data InstBindings a
   = InstBindings
-      { ib_binds :: (LHsBinds a)  -- Bindings for the instance methods
-      , ib_pragmas :: [LSig a]    -- User pragmas recorded for generating
-                                  -- specialised instances
-      , ib_extensions :: [ExtensionFlag] -- any extra extensions that should
+      { ib_tyvars  :: [Name]        -- Names of the tyvars from the instance head
+                                    -- that are lexically in scope in the bindings
+
+      , ib_binds   :: (LHsBinds a)  -- Bindings for the instance methods
+
+      , ib_pragmas :: [LSig a]      -- User pragmas recorded for generating
+                                    -- specialised instances
+
+      , ib_extensions :: [ExtensionFlag] -- Any extra extensions that should
                                          -- be enabled when type-checking this
                                          -- instance; needed for
                                          -- GeneralizedNewtypeDeriving
index c3efb32..5bb0862 100644 (file)
@@ -135,6 +135,7 @@ metaTyConsToDerivStuff tc metaDts =
         d_metaTycon = metaD metaDts
         d_inst   = mk_inst dClas d_metaTycon d_dfun_name
         d_binds  = InstBindings { ib_binds = dBinds
+                                , ib_tyvars = []
                                 , ib_pragmas = []
                                 , ib_extensions = []
                                 , ib_derived = True }
@@ -145,6 +146,7 @@ metaTyConsToDerivStuff tc metaDts =
         c_insts = [ mk_inst cClas c ds
                   | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
         c_binds = [ InstBindings { ib_binds = c
+                                 , ib_tyvars = []
                                  , ib_pragmas = []
                                  , ib_extensions = []
                                  , ib_derived = True }
@@ -157,6 +159,7 @@ metaTyConsToDerivStuff tc metaDts =
         s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
                       (myZip2 s_metaTycons s_dfun_names)
         s_binds = [ [ InstBindings { ib_binds = s
+                                   , ib_tyvars = []
                                    , ib_pragmas = []
                                    , ib_extensions = []
                                    , ib_derived = True }
index 86a2c14..10bc466 100644 (file)
@@ -542,6 +542,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         ; let inst_info = InstInfo { iSpec  = ispec
                                    , iBinds = InstBindings
                                      { ib_binds = binds
+                                     , ib_tyvars = map Var.varName tyvars -- Scope over bindings
                                      , ib_pragmas = uprags
                                      , ib_extensions = []
                                      , ib_derived = False } }
@@ -812,7 +813,6 @@ So right here in tcInstDecls2 we must re-extend the type envt with
 the default method Ids replete with their INLINE pragmas.  Urk.
 
 \begin{code}
-
 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
             -- Returns a binding for the dfun
 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
@@ -838,11 +838,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
 
         -- Typecheck the methods
        ; (meth_ids, meth_binds)
-           <- tcExtendTyVarEnv inst_tyvars $
-                -- The inst_tyvars scope over the 'where' part
-                -- Those tyvars are inside the dfun_id's type, which is a bit
-                -- bizarre, but OK so long as you realise it!
-              tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
+           <- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
                                 inst_tys spec_inst_info
                                 op_items ibinds
 
@@ -1175,10 +1171,13 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                   (spec_inst_prags, prag_fn)
                   op_items (InstBindings { ib_binds = binds
+                                         , ib_tyvars = lexical_tvs
                                          , ib_pragmas = sigs
                                          , ib_extensions = exts
                                          , ib_derived    = is_derived })
-  = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
+  = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
+       -- The lexical_tvs scope over the 'where' part
+    do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
        ; let hs_sig_fn = mkHsSigFun sigs
        ; checkMinimalDefinition
        ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }