Hurrah! This major commit adds support for scoped kind variables,
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 2 Mar 2012 16:32:58 +0000 (16:32 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 2 Mar 2012 16:32:58 +0000 (16:32 +0000)
which (finally) fills out the functionality of polymorphic kinds.
It also fixes numerous bugs.

Main changes are:

Renaming stuff
~~~~~~~~~~~~~~
* New type in HsTypes:
     data HsBndrSig sig = HsBSig sig [Name]
  which is used for type signatures in patterns, and kind signatures
  in types.  So when you say
       f (x :: [a]) = x ++ x
  or
       data T (f :: k -> *) (x :: *) = MkT (f x)
  the signatures in both cases are a HsBndrSig.

* The [Name] in HsBndrSig records the variables bound by the
  pattern, that is 'a' in the first example, 'k' in the second,
  and nothing in the third.  The renamer initialises the field.

* As a result I was able to get rid of
     RnHsSyn.extractHsTyNames :: LHsType Name -> NameSet
  and its friends altogether.  Deleted the entire module!
  This led to some knock-on refactoring; in particular the
  type renamer now returns the free variables just like the
  term renamer.

Kind-checking types: mainly TcHsType
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A major change is that instead of kind-checking types in two
passes, we now do one. Under the old scheme, the first pass did
kind-checking and (hackily) annotated the HsType with the
inferred kinds; and the second pass desugared the HsType to a
Type.  But now that we have kind variables inside types, the
first pass (TcHsType.tc_hs_type) can go straight to Type, and
zonking will squeeze out any kind unification variables later.

This is much nicer, but it was much more fiddly than I had expected.

The nastiest corner is this: it's very important that tc_hs_type
uses lazy constructors to build the returned type. See
Note [Zonking inside the knot] in TcHsType.

Type-checking type and class declarations: mainly TcTyClsDecls
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I did tons of refactoring in TcTyClsDecls.  Simpler and nicer now.

Typechecking bindings: mainly TcBinds
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I rejigged (yet again) the handling of type signatures in TcBinds.
It's a bit simpler now.  The main change is that tcTySigs goes
right through to a TcSigInfo in one step; previously it was split
into two, part here and part later.

Unsafe coercions
~~~~~~~~~~~~~~~~
Usually equality coercions have exactly the same kind on both
sides.  But we do allow an *unsafe* coercion between Int# and Bool,
say, used in
    case error Bool "flah" of { True -> 3#; False -> 0# }
-->
    (error Bool "flah") |> unsafeCoerce Bool Int#

So what is the instantiation of (~#) here?
   unsafeCoerce Bool Int# :: (~#) ??? Bool Int#
I'm using OpenKind here for now, but it's un-satisfying that
the lhs and rhs of the ~ don't have precisely the same kind.

More minor
~~~~~~~~~~
* HsDecl.TySynonym has its free variables attached, which makes
  the cycle computation in TcTyDecls.mkSynEdges easier.

* Fixed a nasty reversed-comparison bug in FamInstEnv:
  @@ -490,7 +490,7 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys
     n_tys = length tys
     extra_tys = drop arity tys
     (match_tys, add_extra_tys)
-       | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys)
+       | arity < n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys)
        | otherwise     = (tys,            \res_tys -> res_tys)

56 files changed:
compiler/basicTypes/DataCon.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/DsMeta.hs
compiler/ghc.cabal.in
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnHsSyn.lhs [deleted file]
compiler/rename/RnNames.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/stgSyn/StgLint.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcSplice.lhs-boot
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/InstEnv.lhs
compiler/types/Kind.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs

index 3f747f9..3ab3fd8 100644 (file)
@@ -563,7 +563,7 @@ mkDataCon name declared_infix
          mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
-eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
+eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
 
 mk_pred_strict_mark :: PredType -> HsBang
 mk_pred_strict_mark pred 
index 7487c66..d98a4ad 100644 (file)
@@ -29,7 +29,6 @@ import Demand
 import DataCon
 import TyCon
 import Type
-import Kind
 import Coercion
 import StaticFlags
 import BasicTypes
@@ -312,12 +311,7 @@ pprTypedLetBinder binder
 pprKindedTyVarBndr :: TyVar -> SDoc
 -- Print a type variable binder with its kind (but not if *)
 pprKindedTyVarBndr tyvar
-  = ptext (sLit "@") <+> ppr tyvar <> opt_kind
-  where
-    opt_kind   -- Print the kind if not *
-       | isLiftedTypeKind kind = empty
-       | otherwise = dcolon <> pprKind kind
-    kind = tyVarKind tyvar
+  = ptext (sLit "@") <+> pprTvBndr tyvar
 
 -- pprIdBndr does *not* print the type
 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
index 7daa037..bef7b5d 100644 (file)
@@ -252,8 +252,8 @@ repTyFamily :: LTyClDecl Name
             -> ProcessTyVarBinds TH.Dec
             -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
-                              tcdLName = tc, tcdTyVars = tvs, 
-                              tcdKind = opt_kind }))
+                              tcdLName   = tc, tcdTyVars = tvs, 
+                              tcdKindSig = opt_kind }))
             tyVarBinds
   = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
        ; dec <- tyVarBinds tvs $ \bndrs ->
@@ -403,7 +403,7 @@ in_subst _ []          = False
 in_subst n ((n',_):ns) = n==n' || in_subst n ns
 
 mkGadtCtxt :: [Name]           -- Tyvars of the data type
-           -> ResType Name
+           -> ResType (LHsType Name)
           -> DsM (HsContext Name, [(Name,Name)])
 -- Given a data type in GADT syntax, figure out the equality 
 -- context, so that we can represent it with an explicit 
@@ -607,7 +607,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm
   = repKind ki >>= repKindedTV nm
 
 -- represent a type context
index cdacbf4..20a2e47 100644 (file)
@@ -356,7 +356,6 @@ Library
         RnEnv
         RnExpr
         RnHsDoc
-        RnHsSyn
         RnNames
         RnPat
         RnSource
index 068a9ee..4bff46c 100644 (file)
@@ -161,7 +161,9 @@ cvtDec (PragmaD prag)
 cvtDec (TySynD tc tvs rhs)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
-       ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
+       ; returnL $ TyClD (TySynonym { tcdLName = tc' 
+                                     , tcdTyVars = tvs', tcdTyPats = Nothing
+                                     , tcdSynRhs = rhs', tcdFVs = placeHolderNames }) }
 
 cvtDec (DataD ctxt tc tvs constrs derivs)
   = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
@@ -235,7 +237,9 @@ cvtDec (TySynInstD tc tys rhs)
   = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
        ; rhs' <- cvtType rhs
        ; returnL $ InstD $ FamInstDecl $ 
-                    TySynonym tc' tvs' tys' rhs' }
+                    TySynonym { tcdLName = tc'
+                              , tcdTyVars = tvs', tcdTyPats = tys'
+                              , tcdSynRhs = rhs', tcdFVs = placeHolderNames } }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
@@ -753,9 +757,10 @@ cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 cvtp TH.WildP          = return $ WildPat void
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
-                          ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
+                           ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 cvtp (ListP ps)        = do { ps' <- cvtPats ps; return $ ListPat ps' void }
-cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
+                            ; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
@@ -791,8 +796,7 @@ cvt_tv (TH.PlainTV nm)
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' ki' placeHolderKind
-       }
+       ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
index 49a5b91..26d49f7 100644 (file)
@@ -449,10 +449,10 @@ data TyClDecl name
 
 
   | -- | @type/data family T :: *->*@
-    TyFamily {  tcdFlavour:: FamilyFlavour,             -- type or data
-                tcdLName  :: Located name,              -- type constructor
-                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
-                tcdKind   :: Maybe (LHsKind name)       -- result kind
+    TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
+                tcdLName   :: Located name,              -- type constructor
+                tcdTyVars  :: [LHsTyVarBndr name],       -- type variables
+                tcdKindSig :: Maybe (LHsKind name)       -- result kind
     }
 
 
@@ -501,7 +501,9 @@ data TyClDecl name
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns
                   -- See Note [tcdTyVars and tcdTyPats] 
 
-                tcdSynRhs :: LHsType name               -- ^ synonym expansion
+                tcdSynRhs :: LHsType name,              -- ^ synonym expansion
+                tcdFVs    :: NameSet                    -- ^ Free tycons of the decl
+                                                        -- (Used for cycle detection)
     }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
@@ -634,7 +636,7 @@ instance OutputableBndr name
         = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
 
     ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
-                   tcdTyVars = tyvars, tcdKind = mb_kind})
+                   tcdTyVars = tyvars, tcdKindSig = mb_kind})
       = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
         where
           pp_flavour = case flavour of
@@ -766,7 +768,7 @@ data ConDecl name
     , con_details   :: HsConDeclDetails name
         -- ^ The main payload
 
-    , con_res       :: ResType name
+    , con_res       :: ResType (LHsType name)
         -- ^ Result type of the constructor
 
     , con_doc       :: Maybe LHsDocString
@@ -786,16 +788,16 @@ hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds
 
-data ResType name
+data ResType ty
    = ResTyH98           -- Constructor was declared using Haskell 98 syntax
-   | ResTyGADT (LHsType name)   -- Constructor was declared using GADT-style syntax,
-                                --      and here is its result type
+   | ResTyGADT ty       -- Constructor was declared using GADT-style syntax,
+                        --      and here is its result type
    deriving (Data, Typeable)
 
-instance OutputableBndr name => Outputable (ResType name) where
+instance Outputable ty => Outputable (ResType ty) where
          -- Debugging only
-   ppr ResTyH98 = ptext (sLit "ResTyH98")
-   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
+   ppr ResTyH98       = ptext (sLit "ResTyH98")
+   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
 \end{code}
 
 
@@ -1061,10 +1063,10 @@ data RuleDecl name
 
 data RuleBndr name
   = RuleBndr (Located name)
-  | RuleBndrSig (Located name) (LHsType name)
+  | RuleBndrSig (Located name) (HsBndrSig (LHsType name))
   deriving (Data, Typeable)
 
-collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
+collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
index 2241d7b..1a5e206 100644 (file)
@@ -132,7 +132,7 @@ data Pat id
 
         ------------ Pattern type signatures ---------------
   | SigPatIn        (LPat id)           -- Pattern with a type signature
-                    (LHsType id)
+                    (HsBndrSig (LHsType id))
 
   | SigPatOut       (LPat id)           -- Pattern with a type signature
                     Type
index acd4df9..696b48f 100644 (file)
@@ -17,7 +17,7 @@ HsTypes: Abstract syntax: user-defined types
 
 module HsTypes (
        HsType(..), LHsType, HsKind, LHsKind,
-       HsTyVarBndr(..), LHsTyVarBndr,
+       HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
        HsTupleSort(..), HsExplicitFlag(..),
        HsContext, LHsContext,
        HsQuasiQuote(..),
@@ -29,7 +29,7 @@ module HsTypes (
        ConDeclField(..), pprConDeclFields,
        
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-       hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
+       hsTyVarName, hsTyVarNames, 
        hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
@@ -37,6 +37,7 @@ module HsTypes (
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
        splitHsAppTys, mkHsAppTys, mkHsOpTy,
+        placeHolderBndrs,
 
        -- Printing
        pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
@@ -47,6 +48,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 import HsLit
 
 import NameSet( FreeVars )
+import Name( Name )
 import Type
 import HsDoc
 import BasicTypes
@@ -119,12 +121,44 @@ type LHsType name = Located (HsType name)
 type HsKind name = HsType name
 type LHsKind name = Located (HsKind name)
 
+type LHsTyVarBndr name = Located (HsTyVarBndr name)
+
+data HsBndrSig sig 
+  = HsBSig 
+       sig 
+       [Name]   -- The *binding* type/kind names of this signature
+  deriving (Data, Typeable)
+-- Consider a binder (or pattern) decoarated with a type or kind, 
+--    \ (x :: a -> a). blah
+--    forall (a :: k -> *) (b :: k). blah
+-- Then we use a LHsBndrSig on the binder, so that the
+-- renamer can decorate it with the variables bound
+-- by the pattern ('a' in the first example, 'k' in the second),
+-- assuming that neither of them is in scope already
+
+placeHolderBndrs :: [Name]
+-- Used for the NameSet in FunBind and PatBind prior to the renamer
+placeHolderBndrs = panic "placeHolderBndrs"
+
+data HsTyVarBndr name
+  = UserTyVar          -- No explicit kinding
+         name          -- See Note [Printing KindedTyVars]
+         PostTcKind
+
+  | KindedTyVar
+         name
+         (HsBndrSig (LHsKind name))   -- The user-supplied kind signature
+         PostTcKind
+      --  *** NOTA BENE *** A "monotype" in a pragma can have
+      -- for-alls in it, (mostly to do with dictionaries).  These
+      -- must be explicitly Kinded.
+  deriving (Data, Typeable)
+
 data HsType name
   = HsForAllTy HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
                                        -- the user wrote it originally, so that the printer can
                                        -- print it as the user wrote it
-               [LHsTyVarBndr name]     -- With ImplicitForAll, this is the empty list
-                                       -- until the renamer fills in the variables
+               [LHsTyVarBndr name]     -- See Note [HsForAllTy tyvar binders]
                (LHsContext name)
                (LHsType name)
 
@@ -195,6 +229,22 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
 mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
 \end{code}
 
+Note [HsForAllTy tyvar binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+After parsing:
+  * Implicit => empty
+    Explicit => the varibles the user wrote
+
+After renaming
+  * Implicit => the *type* variables free in the type
+    Explicit => the variables the user wrote (renamed)
+
+Note that in neither case do we inclde the kind variables.
+In the explicit case, the [HsTyVarBndr] can bring kind variables
+into scope:    f :: forall (a::k->*) (b::k). a b -> Int
+but we do not record them explicitly, similar to the case
+for the type variables in a pattern type signature.
+
 Note [Unit tuples]
 ~~~~~~~~~~~~~~~~~~
 Consider the type
@@ -323,22 +373,6 @@ hsExplicitTvs (L _ (HsForAllTy Explicit tvs _ _)) = hsLTyVarNames tvs
 hsExplicitTvs _                                   = []
 
 ---------------------
-type LHsTyVarBndr name = Located (HsTyVarBndr name)
-
-data HsTyVarBndr name
-  = UserTyVar          -- No explicit kinding
-         name          -- See Note [Printing KindedTyVars]
-         PostTcKind
-
-  | KindedTyVar
-         name
-         (LHsKind name)        -- The user-supplied kind signature
-         PostTcKind
-      --  *** NOTA BENE *** A "monotype" in a pragma can have
-      -- for-alls in it, (mostly to do with dictionaries).  These
-      -- must be explicitly Kinded.
-  deriving (Data, Typeable)
-
 hsTyVarName :: HsTyVarBndr name -> name
 hsTyVarName (UserTyVar n _)   = n
 hsTyVarName (KindedTyVar n _ _) = n
@@ -368,19 +402,6 @@ hsLTyVarLocName = fmap hsTyVarName
 
 hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
 hsLTyVarLocNames = map hsLTyVarLocName
-
-replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2  -- new type name
-                    -> (LHsKind name1 -> m (LHsKind name2))  -- kind renaming
-                    -> m (HsTyVarBndr name2)
-replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k
-replaceTyVarName (KindedTyVar _ k tck) n' rn = do
-  k' <- rn k
-  return $ KindedTyVar n' k' tck
-
-replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2
-                  -> (LHsKind name1 -> m (LHsKind name2))
-                  -> m (LHsTyVarBndr name2)
-replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc
 \end{code}
 
 
@@ -468,6 +489,9 @@ splitHsFunType other                   = ([], other)
 instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
+instance (Outputable sig) => Outputable (HsBndrSig sig) where
+    ppr (HsBSig ty _) = ppr ty
+
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name _)      = ppr name
     ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind]
index 293f5b0..f7a1a10 100644 (file)
@@ -761,17 +761,17 @@ lPatImplicits = hs_lpat
 %************************************************************************
 
 \begin{code}
-collectSigTysFromPats :: [InPat name] -> [LHsType name]
+collectSigTysFromPats :: [InPat name] -> [HsBndrSig (LHsType name)]
 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
 
-collectSigTysFromPat :: InPat name -> [LHsType name]
+collectSigTysFromPat :: InPat name -> [HsBndrSig (LHsType name)]
 collectSigTysFromPat pat = collect_sig_lpat pat []
 
-collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
+collect_sig_lpat :: InPat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)]
 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
 
-collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
-collect_sig_pat (SigPatIn pat ty)      acc = collect_sig_lpat pat (ty:acc)
+collect_sig_pat :: Pat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)]
+collect_sig_pat (SigPatIn pat ty)   acc = collect_sig_lpat pat (ty:acc)
 
 collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
 collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
index ff98b74..8de1e0b 100644 (file)
@@ -871,7 +871,7 @@ rule_var_list :: { [RuleBndr RdrName] }
 
 rule_var :: { RuleBndr RdrName }
         : varid                                 { RuleBndr $1 }
-        | '(' varid '::' ctype ')'              { RuleBndrSig $2 $4 }
+        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
@@ -1102,7 +1102,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
@@ -1135,6 +1135,7 @@ akind :: { LHsKind RdrName }
         : '*'                    { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
         | '(' kind ')'           { LL $ HsParTy $2 }
         | pkind                  { $1 }
+        | tyvar                  { L1 $ HsTyVar (unLoc $1) }
 
 pkind :: { LHsKind RdrName }  -- promoted type, see Note [Promotion]
         : qtycon                          { L1 $ HsTyVar $ unLoc $1 }
index 80d4943..872bcde 100644 (file)
@@ -375,7 +375,9 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind
+                  where
+                    bsig = HsBSig (toHsKind k) placeHolderBndrs
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
index 59e6727..be1f5c4 100644 (file)
@@ -218,7 +218,9 @@ mkTySynonym :: SrcSpan
 mkTySynonym loc is_family lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; (tyvars, typats) <- checkTParams is_family lhs tparams
-       ; return (L loc (TySynonym tc tyvars typats rhs)) }
+       ; return (L loc (TySynonym { tcdLName = tc
+                                  , tcdTyVars = tyvars, tcdTyPats = typats
+                                  , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
@@ -499,7 +501,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv k placeHolderKind))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
     chk t@(L l _)
@@ -636,7 +638,7 @@ checkAPat dynflags loc e0 = case e0 of
                             let t' = case t of
                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
                                        other -> other
-                            return (SigPatIn e t')
+                            return (SigPatIn e (HsBSig t' placeHolderBndrs))
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
index 02e2e47..04bda6b 100644 (file)
@@ -477,7 +477,7 @@ keep different state threads separate.  It is represented by nothing at all.
 
 \begin{code}
 mkStatePrimTy :: Type -> Type
-mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
+mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty]
 
 statePrimTyCon :: TyCon   -- See Note [The State# TyCon]
 statePrimTyCon  = pcPrimTyCon statePrimTyConName 1 VoidRep
@@ -523,17 +523,17 @@ arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName          PtrRe
 mutableArrayArrayPrimTyCon = pcPrimTyCon  mutableArrayArrayPrimTyConName 1 PtrRep
 
 mkArrayPrimTy :: Type -> Type
-mkArrayPrimTy elt          = mkTyConApp arrayPrimTyCon [elt]
+mkArrayPrimTy elt          = mkNakedTyConApp arrayPrimTyCon [elt]
 byteArrayPrimTy :: Type
 byteArrayPrimTy                    = mkTyConTy byteArrayPrimTyCon
 mkArrayArrayPrimTy :: Type
 mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon
 mkMutableArrayPrimTy :: Type -> Type -> Type
-mkMutableArrayPrimTy s elt  = mkTyConApp mutableArrayPrimTyCon [s, elt]
+mkMutableArrayPrimTy s elt  = mkNakedTyConApp mutableArrayPrimTyCon [s, elt]
 mkMutableByteArrayPrimTy :: Type -> Type
-mkMutableByteArrayPrimTy s  = mkTyConApp mutableByteArrayPrimTyCon [s]
+mkMutableByteArrayPrimTy s  = mkNakedTyConApp mutableByteArrayPrimTyCon [s]
 mkMutableArrayArrayPrimTy :: Type -> Type
-mkMutableArrayArrayPrimTy s = mkTyConApp mutableArrayArrayPrimTyCon [s]
+mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s]
 \end{code}
 
 %************************************************************************
@@ -547,7 +547,7 @@ mutVarPrimTyCon :: TyCon
 mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep
 
 mkMutVarPrimTy :: Type -> Type -> Type
-mkMutVarPrimTy s elt       = mkTyConApp mutVarPrimTyCon [s, elt]
+mkMutVarPrimTy s elt       = mkNakedTyConApp mutVarPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
@@ -561,7 +561,7 @@ mVarPrimTyCon :: TyCon
 mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep
 
 mkMVarPrimTy :: Type -> Type -> Type
-mkMVarPrimTy s elt         = mkTyConApp mVarPrimTyCon [s, elt]
+mkMVarPrimTy s elt         = mkNakedTyConApp mVarPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
@@ -575,7 +575,7 @@ tVarPrimTyCon :: TyCon
 tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep
 
 mkTVarPrimTy :: Type -> Type -> Type
-mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt]
+mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
@@ -589,7 +589,7 @@ stablePtrPrimTyCon :: TyCon
 stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep
 
 mkStablePtrPrimTy :: Type -> Type
-mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
+mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty]
 \end{code}
 
 %************************************************************************
@@ -603,7 +603,7 @@ stableNamePrimTyCon :: TyCon
 stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep
 
 mkStableNamePrimTy :: Type -> Type
-mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
+mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty]
 \end{code}
 
 %************************************************************************
@@ -630,7 +630,7 @@ weakPrimTyCon :: TyCon
 weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep
 
 mkWeakPrimTy :: Type -> Type
-mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
+mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v]
 \end{code}
 
 %************************************************************************
@@ -731,5 +731,5 @@ anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
   where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
 
 anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
+anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
 \end{code}
index 7d4edfd..4b7f043 100644 (file)
@@ -54,8 +54,8 @@ module TysWiredIn (
 
        -- * Tuples
        mkTupleTy, mkBoxedTupleTy,
-       tupleTyCon, promotedTupleTyCon,
-        tupleCon, 
+       tupleTyCon, tupleCon, 
+        promotedTupleTyCon, promotedTupleDataCon,
        unitTyCon, unitDataCon, unitDataConId, pairTyCon, 
        unboxedUnitTyCon, unboxedUnitDataCon, 
         unboxedSingletonTyCon, unboxedSingletonDataCon,
@@ -88,6 +88,7 @@ import TysPrim
 import Coercion
 import Constants       ( mAX_TUPLE_SIZE )
 import Module          ( Module )
+import Type             ( mkTyConApp )
 import DataCon
 import Var
 import TyCon
@@ -328,6 +329,9 @@ tupleTyCon ConstraintTuple    i = fst (factTupleArr    ! i)
 promotedTupleTyCon :: TupleSort -> Arity -> TyCon
 promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i)
 
+promotedTupleDataCon :: TupleSort -> Arity -> TyCon
+promotedTupleDataCon sort i = buildPromotedDataCon (tupleCon sort i)
+
 tupleCon :: TupleSort -> Arity -> DataCon
 tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)   -- Build one specially
 tupleCon BoxedTuple   i = snd (boxedTupleArr   ! i)
index 969a517..6a7bfbe 100644 (file)
@@ -33,10 +33,9 @@ module RnBinds (
 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 
 import HsSyn
-import RnHsSyn
 import TcRnMonad
 import TcEvidence     ( emptyTcEvBinds )
-import RnTypes        ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
+import RnTypes        ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
 import RnPat
 import RnEnv
 import DynFlags
@@ -184,8 +183,8 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 -- Return a single HsBindGroup with empty binds and renamed signatures
 rnTopBindsBoot (ValBindsIn mbinds sigs)
   = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
-       ; sigs' <- renameSigs HsBootCtxt sigs
-       ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
+       ; (sigs', fvs) <- renameSigs HsBootCtxt sigs
+       ; return (ValBindsOut [] sigs', usesOnly fvs) }
 rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
 \end{code}
 
@@ -291,13 +290,13 @@ rnValBindsRHS :: HsSigCtxt
               -> RnM (HsValBinds Name, DefUses)
 
 rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
-  = do { sigs' <- renameSigs ctxt sigs
+  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
        ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
        ; case depAnalBinds binds_w_dus of
            (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
               where
                 valbind' = ValBindsOut anal_binds sigs'
-                valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
+                valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
                               -- Put the sig uses *after* the bindings
                               -- so that the binders are removed from 
                               -- the uses in the sigs
@@ -649,7 +648,7 @@ signatures.  We'd only need this if we wanted to report unused tyvars.
 \begin{code}
 renameSigs :: HsSigCtxt 
           -> [LSig RdrName]
-          -> RnM [LSig Name]
+          -> RnM ([LSig Name], FreeVars)
 -- Renames the signatures and performs error checks
 renameSigs ctxt sigs 
   = do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs)  -- Duplicate
@@ -662,12 +661,12 @@ renameSigs ctxt sigs
                --             op :: a -> a
                --             default op :: Eq a => a -> a
                
-       ; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs
+       ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
 
        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
 
-       ; return good_sigs } 
+       ; return (good_sigs, sig_fvs) } 
 
 ----------------------
 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
@@ -679,26 +678,26 @@ 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)
+renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
 -- FixitySig is renamed elsewhere.
 renameSig _ (IdSig x)
-  = return (IdSig x)     -- Actually this never occurs
+  = return (IdSig x, emptyFVs)   -- Actually this never occurs
 
 renameSig ctxt sig@(TypeSig vs ty)
   = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
-       ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
-       ; return (TypeSig new_vs new_ty) }
+       ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+       ; return (TypeSig new_vs new_ty, fvs) }
 
 renameSig ctxt sig@(GenericSig vs ty)
   = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
         ; unless defaultSigs_on (addErr (defaultSigErr sig))
         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
-       ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
-       ; return (GenericSig new_v new_ty) }
+       ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+       ; return (GenericSig new_v new_ty, fvs) }
 
 renameSig _ (SpecInstSig ty)
-  = do { new_ty <- rnLHsType SpecInstSigCtx ty
-       ; return (SpecInstSig new_ty) }
+  = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
+       ; return (SpecInstSig new_ty,fvs) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
 -- so, in the top-level case (when mb_names is Nothing)
@@ -708,16 +707,16 @@ renameSig ctxt sig@(SpecSig v ty inl)
   = do { new_v <- case ctxt of 
                      TopSigCtxt -> lookupLocatedOccRn v
                      _          -> lookupSigOccRn ctxt sig v
-       ; new_ty <- rnHsSigType (quotes (ppr v)) ty
-       ; return (SpecSig new_v new_ty inl) }
+       ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
+       ; return (SpecSig new_v new_ty inl, fvs) }
 
 renameSig ctxt sig@(InlineSig v s)
   = do { new_v <- lookupSigOccRn ctxt sig v
-       ; return (InlineSig new_v s) }
+       ; return (InlineSig new_v s, emptyFVs) }
 
 renameSig ctxt sig@(FixSig (FixitySig v f))
   = do { new_v <- lookupSigOccRn ctxt sig v
-       ; return (FixSig (FixitySig new_v f)) }
+       ; return (FixSig (FixitySig new_v f), emptyFVs) }
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
@@ -778,7 +777,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
        { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
 
        ; return (Match pats' Nothing grhss', grhss_fvs) }}
-       -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
 
 resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc 
 resSigErr ctxt match ty
index ecd2cd3..f1adba6 100644 (file)
 module RnEnv ( 
        newTopSrcBinder, 
        lookupLocatedTopBndrRn, lookupTopBndrRn,
-       lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn,
+       lookupLocatedOccRn, lookupOccRn, 
+        lookupLocalOccRn_maybe, 
+        lookupTypeOccRn, lookupKindOccRn, 
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
 
        HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
 
        lookupFixityRn, lookupTyFixityRn, 
-       lookupInstDeclBndr, lookupSubBndrOcc, greRdrName,
+       lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName,
+        greRdrName,
         lookupSubBndrGREs, lookupConstructorFields,
        lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
        lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
@@ -31,7 +34,6 @@ module RnEnv (
        MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
        addLocalFixities,
        bindLocatedLocalsFV, bindLocatedLocalsRn,
-       bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
        extendTyVarEnvFVRn,
 
        checkDupRdrNames, checkDupAndShadowedRdrNames,
@@ -40,7 +42,6 @@ module RnEnv (
        warnUnusedMatches,
        warnUnusedTopBinds, warnUnusedLocalBinds,
        dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg,
-
         HsDocContext(..), docOfHsDocContext
     ) where
 
@@ -49,7 +50,6 @@ module RnEnv (
 import LoadIface       ( loadInterfaceForName, loadSrcInterface )
 import IfaceEnv
 import HsSyn
-import RdrHsSyn                ( extractHsTyRdrTyVars )
 import RdrName
 import HscTypes
 import TcEnv           ( tcLookupDataCon, tcLookupField, isBrackStage )
@@ -72,7 +72,6 @@ import ListSetOps     ( removeDups )
 import DynFlags
 import FastString
 import Control.Monad
-import Data.List
 import qualified Data.Set as Set
 \end{code}
 
@@ -271,6 +270,25 @@ lookupInstDeclBndr cls what rdr
   where
     doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
 
+
+-----------------------------------------------
+lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
+-- Used for TyData and TySynonym only, 
+-- both ordinary ones and family instances
+-- See Note [Family instance binders]
+lookupTcdName mb_cls tc_decl
+  | not (isFamInstDecl tc_decl)   -- The normal case
+  = ASSERT2( isNothing mb_cls, ppr tc_rdr )     -- Parser prevents this
+    lookupLocatedTopBndrRn tc_rdr
+
+  | Just cls <- mb_cls      -- Associated type; c.f RnBinds.rnMethodBind
+  = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
+
+  | otherwise               -- Family instance; tc_rdr is an *occurrence*
+  = lookupLocatedOccRn tc_rdr 
+  where
+    tc_rdr = tcdLName tc_decl
+
 -----------------------------------------------
 lookupConstructorFields :: Name -> RnM [Name]
 -- Look up the fields of a given constructor
@@ -374,6 +392,40 @@ lookupSubBndrGREs env parent rdr_name
     parent_is _ _                               = False
 \end{code}
 
+Note [Family instance binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data family F a
+  data instance F T = X1 | X2
+
+The 'data instance' decl has an *occurrence* of F (and T), and *binds*
+X1 and X2.  (This is unlike a normal data type declaration which would
+bind F too.)  So we want an AvailTC F [X1,X2].
+
+Now consider a similar pair:
+  class C a where
+    data G a
+  instance C S where
+    data G S = Y1 | Y2
+
+The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
+
+But there is a small complication: in an instance decl, we don't use
+qualified names on the LHS; instead we use the class to disambiguate.
+Thus:
+  module M where
+    import Blib( G )
+    class C a where
+      data G a
+    instance C S where
+      data G S = Y1 | Y2
+Even though there are two G's in scope (M.G and Blib.G), the occurence
+of 'G' in the 'instance C S' decl is unambiguous, becuase C has only
+one associated type called G. This is exactly what happens for methods,
+and it is only consistent to do the same thing for types. That's the
+role of the function lookupTcdName; the (Maybe Name) give the class of
+the encloseing instance decl, if any.
+
 Note [Looking up Exact RdrNames]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Exact RdrNames are generated by Template Haskell.  See Note [Binders
@@ -452,10 +504,18 @@ lookupOccRn rdr_name = do
   opt_name <- lookupOccRn_maybe rdr_name
   maybe (unboundName WL_Any rdr_name) return opt_name
 
+lookupKindOccRn :: RdrName -> RnM Name
+-- Looking up a name occurring in a kind
+lookupKindOccRn rdr_name
+  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case mb_name of
+           Just name -> return name
+           Nothing -> unboundName WL_Any rdr_name  }
+
 -- lookupPromotedOccRn looks up an optionally promoted RdrName.
-lookupPromotedOccRn :: RdrName -> RnM Name
+lookupTypeOccRn :: RdrName -> RnM Name
 -- see Note [Demotion] 
-lookupPromotedOccRn rdr_name 
+lookupTypeOccRn rdr_name 
   = do { mb_name <- lookupOccRn_maybe rdr_name 
        ; case mb_name of {
              Just name -> return name ;
@@ -1018,42 +1078,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope
     return (thing, delFVs names fvs)
 
 -------------------------------------
-bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
-  -- Find the type variables in the pattern type 
-  -- signatures that must be brought into scope
-bindPatSigTyVars tys thing_inside
-  = do         { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
-       ; if not scoped_tyvars then 
-               thing_inside []
-         else 
-    do         { name_env <- getLocalRdrEnv
-       ; let locd_tvs  = [ tv | ty <- tys
-                              , tv <- extractHsTyRdrTyVars ty
-                              , not (unLoc tv `elemLocalRdrEnv` name_env) ]
-             nubbed_tvs = nubBy eqLocated locd_tvs
-               -- The 'nub' is important.  For example:
-               --      f (x :: t) (y :: t) = ....
-               -- We don't want to complain about binding t twice!
-
-       ; bindLocatedLocalsRn nubbed_tvs thing_inside }}
-
-bindPatSigTyVarsFV :: [LHsType RdrName]
-                  -> RnM (a, FreeVars)
-                  -> RnM (a, FreeVars)
-bindPatSigTyVarsFV tys thing_inside
-  = bindPatSigTyVars tys       $ \ tvs ->
-    thing_inside               `thenM` \ (result,fvs) ->
-    return (result, fvs `delListFromNameSet` tvs)
-
-bindSigTyVarsFV :: [Name]
-               -> RnM (a, FreeVars)
-               -> RnM (a, FreeVars)
-bindSigTyVarsFV tvs thing_inside
-  = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
-       ; if not scoped_tyvars then 
-               thing_inside 
-         else
-               bindLocalNamesFV tvs thing_inside }
 
 extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
        -- This function is used only in rnSourceDecl on InstDecl
@@ -1148,24 +1172,19 @@ unboundName wl rdr = unboundNameX wl rdr empty
 unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
 unboundNameX where_look rdr_name extra
   = do  { show_helpful_errors <- doptM Opt_HelpfulErrors
-        ; let err = unknownNameErr rdr_name $$ extra
+        ; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+              err = unknownNameErr what rdr_name $$ extra
         ; if not show_helpful_errors
           then addErr err
           else do { suggestions <- unknownNameSuggestErr where_look rdr_name
                   ; addErr (err $$ suggestions) }
 
-        ; env <- getGlobalRdrEnv;
-       ; traceRn (vcat [unknownNameErr rdr_name, 
-                        ptext (sLit "Global envt is:"),
-                        nest 3 (pprGlobalRdrEnv env)])
-
         ; return (mkUnboundName rdr_name) }
 
-unknownNameErr :: RdrName -> SDoc
-unknownNameErr rdr_name
+unknownNameErr :: SDoc -> RdrName -> SDoc
+unknownNameErr what rdr_name
   = vcat [ hang (ptext (sLit "Not in scope:")) 
-             2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
-                         <+> quotes (ppr rdr_name))
+             2 (what <+> quotes (ppr rdr_name))
         , extra ]
   where
     extra | rdr_name == forall_tv_RDR = perhapsForallMsg
index 7caae61..b884d4a 100644 (file)
@@ -34,8 +34,7 @@ import HsSyn
 import TcRnMonad
 import TcEnv           ( thRnBrack )
 import RnEnv
-import RnTypes         ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
-                         mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
+import RnTypes 
 import RnPat
 import DynFlags
 import BasicTypes      ( FixityDirection(..) )
@@ -270,7 +269,7 @@ rnExpr (RecordUpd expr rbinds _ _ _)
                  fvExpr `plusFV` fvRbinds) }
 
 rnExpr (ExprWithTySig expr pty)
-  = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty
+  = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty
        ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
                             rnLExpr expr
        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
@@ -283,7 +282,7 @@ rnExpr (HsIf _ p b1 b2)
        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
 rnExpr (HsType a)
-  = rnHsTypeFVs HsTypeCtx a    `thenM` \ (t, fvT) -> 
+  = rnLHsType HsTypeCtx a      `thenM` \ (t, fvT) -> 
     return (HsType t, fvT)
 
 rnExpr (ArithSeq _ seq)
@@ -607,7 +606,7 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 
 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
 
-rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t
+rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
                         ; return (TypBr t', fvs) }
 
 rnBracket (DecBrL decls) 
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
deleted file mode 100644 (file)
index e2369bb..0000000
+++ /dev/null
@@ -1,159 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module RnHsSyn(
-        -- Names
-        charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name,
-        extractHsTyVars, extractHsTyNames, extractHsTyNames_s,
-        extractFunDepNames, extractHsCtxtTyNames,
-        extractHsTyVarBndrNames, extractHsTyVarBndrNames_s,
-
-        -- Free variables
-        hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
-  ) where
-
-#include "HsVersions.h"
-
-import HsSyn
-import Class            ( FunDep )
-import TysWiredIn       ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
-import Name             ( Name, getName, isTyVarName )
-import NameSet
-import BasicTypes       ( TupleSort )
-import SrcLoc
-import Panic            ( panic )
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection{Free variables}
-%*                                                                      *
-%************************************************************************
-
-These free-variable finders returns tycons and classes too.
-
-\begin{code}
-charTyCon_name, listTyCon_name, parrTyCon_name :: Name
-charTyCon_name    = getName charTyCon
-listTyCon_name    = getName listTyCon
-parrTyCon_name    = getName parrTyCon
-
-tupleTyCon_name :: TupleSort -> Int -> Name
-tupleTyCon_name sort n = getName (tupleTyCon sort n)
-
-extractHsTyVars :: LHsType Name -> NameSet
-extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
-
-extractFunDepNames :: FunDep Name -> NameSet
-extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
-
-extractHsTyNames   :: LHsType Name -> NameSet
--- Also extract names in kinds.
-extractHsTyNames ty
-  = getl ty
-  where
-    getl (L _ ty) = get ty
-
-    get (HsAppTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
-    get (HsListTy ty)          = unitNameSet listTyCon_name `unionNameSets` getl ty
-    get (HsPArrTy ty)          = unitNameSet parrTyCon_name `unionNameSets` getl ty
-    get (HsTupleTy _ tys)      = extractHsTyNames_s tys
-    get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
-    get (HsIParamTy _ ty)      = getl ty
-    get (HsEqTy ty1 ty2)       = getl ty1 `unionNameSets` getl ty2
-    get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
-    get (HsParTy ty)           = getl ty
-    get (HsBangTy _ ty)        = getl ty
-    get (HsRecTy flds)         = extractHsTyNames_s (map cd_fld_type flds)
-    get (HsTyVar tv)           = unitNameSet tv
-    get (HsSpliceTy _ fvs _)   = fvs
-    get (HsQuasiQuoteTy {})    = emptyNameSet
-    get (HsKindSig ty ki)      = getl ty `unionNameSets` getl ki
-    get (HsForAllTy _ tvs
-                    ctxt ty)   = extractHsTyVarBndrNames_s tvs
-                                 (extractHsCtxtTyNames ctxt
-                                  `unionNameSets` getl ty)
-    get (HsDocTy ty _)         = getl ty
-    get (HsCoreTy {})          = emptyNameSet  -- This probably isn't quite right
-                                               -- but I don't think it matters
-    get (HsExplicitListTy _ tys) = extractHsTyNames_s tys
-    get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys
-    get (HsWrapTy {})          = panic "extractHsTyNames"
-
-extractHsTyNames_s  :: [LHsType Name] -> NameSet
-extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
-
-extractHsCtxtTyNames :: LHsContext Name -> NameSet
-extractHsCtxtTyNames (L _ ctxt)
-  = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt
-
-extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet
-extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet
-extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki
-
-extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet
--- Update the name set 'body' by adding the names in the binders
--- kinds and handling scoping.
-extractHsTyVarBndrNames_s [] body = body
-extractHsTyVarBndrNames_s (b:bs) body =
-  (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b))
-  `unionNameSets` extractHsTyVarBndrNames b
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection{Free variables of declarations}
-%*                                                                      *
-%************************************************************************
-
-Return the Names that must be in scope if we are to use this declaration.
-In all cases this is set up for interface-file declarations:
-        - for class decls we ignore the bindings
-        - for instance decls likewise, plus the pragmas
-        - for rule decls, we ignore HsRules
-        - for data decls, we ignore derivings
-
-        *** See "THE NAMING STORY" in HsDecls ****
-
-\begin{code}
-----------------
-hsSigsFVs :: [LSig Name] -> FreeVars
-hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
-
-hsSigFVs :: Sig Name -> FreeVars
-hsSigFVs (TypeSig _ ty)    = extractHsTyNames ty
-hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
-hsSigFVs (SpecInstSig ty)  = extractHsTyNames ty
-hsSigFVs (SpecSig _ ty _)  = extractHsTyNames ty
-hsSigFVs _                 = emptyFVs
-
-----------------
-conDeclFVs :: LConDecl Name -> FreeVars
-conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context,
-                           con_details = details, con_res = res_ty}))
-  = extractHsTyVarBndrNames_s tyvars $
-    extractHsCtxtTyNames context  `plusFV`
-    conDetailsFVs details         `plusFV`
-    conResTyFVs res_ty
-
-conResTyFVs :: ResType Name -> FreeVars
-conResTyFVs ResTyH98       = emptyFVs
-conResTyFVs (ResTyGADT ty) = extractHsTyNames ty
-
-conDetailsFVs :: HsConDeclDetails Name -> FreeVars
-conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details))
-
-bangTyFVs :: LHsType Name -> FreeVars
-bangTyFVs bty = extractHsTyNames (getBangType bty)
-\end{code}
index b1a61db..553c3ef 100644 (file)
@@ -7,7 +7,7 @@
 module RnNames (
         rnImports, getLocalNonValBinders,
         rnExports, extendGlobalRdrEnvRn,
-        gresFromAvails, lookupTcdName,
+        gresFromAvails, 
         reportUnusedNames, finishWarnings,
     ) where
 
@@ -528,6 +528,18 @@ getLocalNonValBinders fixity_env
              ; names@(main_name : _) <- mapM newTopSrcBinder bndrs
              ; return (AvailTC main_name names) }
 
+    new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
+    new_assoc (L _ (FamInstDecl d)) 
+      = do { avail <- new_ti Nothing d
+           ; return [avail] }
+    new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
+      | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
+      = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
+           ; mapM (new_ti (Just cls_nm) . unLoc) ats }
+      | otherwise
+      = return []     -- Do not crash on ill-formed instances
+                      -- Eg   instance !Show Int   Trac #3811c
+
     new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
     new_ti mb_cls ti_decl  -- ONLY for type/data instances
         = ASSERT( isFamInstDecl ti_decl ) 
@@ -535,37 +547,6 @@ getLocalNonValBinders fixity_env
              ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl)
              ; return (AvailTC (unLoc main_name) sub_names) }
                         -- main_name is not bound here!
-
-    new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
-    new_assoc (L _ (FamInstDecl d)) 
-      = do { avail <- new_ti Nothing d
-           ; return [avail] }
-    new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
-      = do { mb_cls_nm <- get_cls_parent inst_ty 
-           ; mapM (new_ti mb_cls_nm . unLoc) ats }
-      where
-        get_cls_parent inst_ty
-          | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
-          = setSrcSpan loc $ do { nm <- lookupGlobalOccRn cls_rdr; return (Just nm) }
-          | otherwise
-          = return Nothing
-
-lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
--- Used for TyData and TySynonym only, 
--- both ordinary ones and family instances
--- See Note [Family instance binders]
-lookupTcdName mb_cls tc_decl
-  | not (isFamInstDecl tc_decl)   -- The normal case
-  = ASSERT2( isNothing mb_cls, ppr tc_rdr )     -- Parser prevents this
-    lookupLocatedTopBndrRn tc_rdr
-
-  | Just cls <- mb_cls      -- Associated type; c.f RnBinds.rnMethodBind
-  = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
-
-  | otherwise               -- Family instance; tc_rdr is an *occurrence*
-  = lookupLocatedOccRn tc_rdr 
-  where
-    tc_rdr = tcdLName tc_decl
 \end{code}
 
 Note [Looking up family names in family instances]
@@ -586,41 +567,6 @@ Solution is simple: process the type family declarations first, extend
 the environment, and then process the type instances.
 
 
-Note [Family instance binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data family F a
-  data instance F T = X1 | X2
-
-The 'data instance' decl has an *occurrence* of F (and T), and *binds*
-X1 and X2.  (This is unlike a normal data type declaration which would
-bind F too.)  So we want an AvailTC F [X1,X2].
-
-Now consider a similar pair:
-  class C a where
-    data G a
-  instance C S where
-    data G S = Y1 | Y2
-
-The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
-
-But there is a small complication: in an instance decl, we don't use
-qualified names on the LHS; instead we use the class to disambiguate.
-Thus:
-  module M where
-    import Blib( G )
-    class C a where
-      data G a
-    instance C S where
-      data G S = Y1 | Y2
-Even though there are two G's in scope (M.G and Blib.G), the occurence
-of 'G' in the 'instance C S' decl is unambiguous, becuase C has only
-one associated type called G. This is exactly what happens for methods,
-and it is only consistent to do the same thing for types. That's the
-role of the function lookupTcdName; the (Maybe Name) give the class of
-the encloseing instance decl, if any.
-
-
 %************************************************************************
 %*                                                                      *
 \subsection{Filtering imports}
index 7dd76bd..162ce22 100644 (file)
@@ -162,6 +162,10 @@ matchNameMaker ctxt = LamMk report_unused
                       StmtCtxt GhciStmt -> False
                       _                 -> True
 
+rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name))
+rnHsSigCps sig 
+  = CpsRn (rnHsBndrSig True PatCtx sig)
+
 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
 newPatName (LamMk report_unused) rdr_name
   = CpsRn (\ thing_inside -> 
@@ -232,11 +236,9 @@ rnPats :: HsMatchContext Name -- for error messages
 rnPats ctxt pats thing_inside
   = do { envs_before <- getRdrEnvs
 
-         -- (0) bring into scope all of the type variables bound by the patterns
          -- (1) rename the patterns, bringing into scope all of the term variables
          -- (2) then do the thing inside.
-       ; bindPatSigTyVarsFV (collectSigTysFromPats pats)     $ 
-         unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
+       ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
         { -- Check for duplicated and shadowed names 
          -- Must do this *after* renaming the patterns
          -- See Note [Collect binders only after renaming] in HsUtils
@@ -310,15 +312,10 @@ rnPatAndThen mk (VarPat rdr)  = do { loc <- liftCps getSrcSpanM
      -- we need to bind pattern variables for view pattern expressions
      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
                                      
-rnPatAndThen mk (SigPatIn pat ty)
-  = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables)
-       ; if patsigs
-         then do { pat' <- rnLPatAndThen mk pat
-                 ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty)
-                ; return (SigPatIn pat' ty') }
-         else do { liftCps (addErr (patSigErr ty))
-                 ; rnPatAndThen mk (unLoc pat) } }
-
+rnPatAndThen mk (SigPatIn pat sig)
+  = do { pat' <- rnLPatAndThen mk pat
+       ; sig' <- rnHsSigCps sig
+       ; return (SigPatIn pat' sig') }
        
 rnPatAndThen mk (LitPat lit)
   | HsString s <- lit
index 1969229..a4a734c 100644 (file)
@@ -25,7 +25,6 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
 import HsSyn
 import RdrName 
 import RdrHsSyn                ( extractHsRhoRdrTyVars )
-import RnHsSyn
 import RnTypes
 import RnBinds
 import RnEnv
@@ -43,6 +42,7 @@ import NameEnv
 import Avail
 import Outputable
 import Bag
+import BasicTypes       ( RuleName )
 import FastString
 import Util            ( filterOut )
 import SrcLoc
@@ -54,7 +54,6 @@ import Digraph                ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 import Control.Monad
 import Data.List( partition )
 import Maybes( orElse )
-import Data.Maybe( isNothing )
 \end{code}
 
 @rnSourceDecl@ `renames' declarations.
@@ -356,7 +355,7 @@ rnAnnProvenance provenance = do
 \begin{code}
 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
 rnDefaultDecl (DefaultDecl tys)
-  = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys
+  = do { (tys', fvs) <- rnLHsTypes doc_str tys
        ; return (DefaultDecl tys', fvs) }
   where
     doc_str = DefaultDeclCtx
@@ -373,7 +372,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 rnHsForeignDecl (ForeignImport name ty _ spec)
   = do { topEnv :: HscEnv <- getTopEnv
        ; name' <- lookupLocatedTopBndrRn name
-       ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
+       ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
 
         -- Mark any PackageTarget style imports as coming from the current package
        ; let packageId = thisPackage $ hsc_dflags topEnv
@@ -383,7 +382,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec)
 
 rnHsForeignDecl (ForeignExport name ty _ spec)
   = do { name' <- lookupLocatedOccRn name
-       ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
+       ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
        ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
        -- NB: a foreign export is an *occurrence site* for name, so 
        --     we add it to the free-variable list.  It might, for example,
@@ -430,18 +429,19 @@ rnSrcInstDecl (FamInstDecl ty_decl)
 
 rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
        -- Used for both source and interface file decls
-  = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty
+  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
        ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
              (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
+             tv_names = hsLTyVarNames inst_tyvars
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
        ; ((ats', other_sigs'), more_fvs) 
-             <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
-                do { (ats', at_fvs) <- rnATInsts cls ats
-                   ; other_sigs'    <- renameSigs (InstDeclCtxt cls) other_sigs
+             <- extendTyVarEnvFVRn tv_names $
+                do { (ats', at_fvs) <- rnATDecls cls tv_names ats
+                   ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
                    ; return ( (ats', other_sigs')
-                            , at_fvs `plusFV` hsSigsFVs other_sigs') }
+                            , at_fvs `plusFV` sig_fvs) }
 
        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all 
@@ -458,16 +458,14 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
        -- works OK. That's why we did the partition game above
        --
-       -- But the (unqualified) method names are in scope
---       ; let binders = collectHsBindsBinders mbinds'
-       ; spec_inst_prags' <- -- bindLocalNames binders $
-                            renameSigs (InstDeclCtxt cls) spec_inst_prags
+       ; (spec_inst_prags', spec_inst_fvs)
+            <- renameSigs (InstDeclCtxt cls) spec_inst_prags
 
        ; let uprags' = spec_inst_prags' ++ other_sigs'
        ; return (ClsInstDecl inst_ty' mbinds' uprags' ats',
                 meth_fvs `plusFV` more_fvs
-                          `plusFV` hsSigsFVs spec_inst_prags'
-                         `plusFV` extractHsTyNames inst_ty') }
+                          `plusFV` spec_inst_fvs
+                         `plusFV` inst_fvs) }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
              -- for the binding group, but we also keep a copy in the instance.
@@ -483,15 +481,18 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
 Renaming of the associated types in instances.  
 
 \begin{code}
-rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
-       -- NB: We allow duplicate associated-type decls; 
-       --     See Note [Associated type instances] in TcInstDcls
-rnATInsts cls atDecls = rnList rnATInst atDecls
-  where
-    rnATInst tydecl@TyData     {} = rnTyClDecl (Just cls) tydecl
-    rnATInst tydecl@TySynonym  {} = rnTyClDecl (Just cls) tydecl
-    rnATInst tydecl               = pprPanic "RnSource.rnATInsts: invalid AT instance" 
-                                             (ppr (tcdName tydecl))
+rnATDecls :: Name        -- Class
+          -> [Name]      -- Type variable binders (but NOT kind variables)
+                         -- See Note [Renaming associated types] in RnTypes
+          -> [LTyClDecl RdrName] 
+          -> RnM ([LTyClDecl Name], FreeVars)
+-- Used for the family declarations and defaults in a class decl
+-- and the family instance declarations in an instance
+-- 
+-- NB: We allow duplicate associated-type decls; 
+--     See Note [Associated type instances] in TcInstDcls
+rnATDecls cls tvs atDecls 
+  = rnList (rnTyClDecl (Just (cls, tvs))) atDecls
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
@@ -520,8 +521,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 rnSrcDerivDecl (DerivDecl ty)
   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
-       ; ty' <- rnLHsInstType (text "In a deriving declaration") ty
-       ; let fvs = extractHsTyNames ty'
+       ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
        ; return (DerivDecl ty', fvs) }
 
 standaloneDerivErr :: SDoc
@@ -539,36 +539,39 @@ standaloneDerivErr
 \begin{code}
 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
-  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)    $
-    bindLocatedLocalsFV (map get_var vars)             $ \ ids ->
-    do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
-               -- NB: The binders in a rule are always Ids
-               --     We don't (yet) support type variables
-
-       ; (lhs', fv_lhs') <- rnLExpr lhs
-       ; (rhs', fv_rhs') <- rnLExpr rhs
-
-       ; checkValidRule rule_name ids lhs' fv_lhs'
-
-       ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
-                 fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
+  = do { let rdr_names_w_loc = map get_var vars
+       ; checkDupAndShadowedRdrNames rdr_names_w_loc
+       ; names <- newLocalBndrsRn rdr_names_w_loc
+       ; bindHsRuleVars rule_name vars names $ \ vars' -> 
+    do { (lhs', fv_lhs') <- rnLExpr lhs
+       ; (rhs', fv_rhs') <- rnLExpr rhs
+       ; checkValidRule rule_name names lhs' fv_lhs'
+       ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+                fv_lhs' `plusFV` fv_rhs') } }
   where
-    doc = RuleCtx rule_name
-  
-    get_var (RuleBndr v)      = v
     get_var (RuleBndrSig v _) = v
+    get_var (RuleBndr v) = v
+
+bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name]
+               -> ([RuleBndr Name] -> RnM (a, FreeVars))
+               -> RnM (a, FreeVars)
+bindHsRuleVars rule_name vars names thing_inside
+  = go vars names $ \ vars' ->
+    bindLocalNamesFV names (thing_inside vars')
+  where
+    doc = RuleCtx rule_name
 
-    rn_var (RuleBndr (L loc _), id)
-       = return (RuleBndr (L loc id), emptyFVs)
-    rn_var (RuleBndrSig (L loc _) t, id)
-       = do { (t', fvs) <- rnHsTypeFVs doc t
-            ; return (RuleBndrSig (L loc id) t', fvs) }
+    go (RuleBndr (L loc _) : vars) (n : ns) thing_inside
+      = go vars ns $ \ vars' ->
+        thing_inside (RuleBndr (L loc n) : vars')
 
-badRuleVar :: FastString -> Name -> SDoc
-badRuleVar name var
-  = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
-        ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
-               ptext (sLit "does not appear on left hand side")]
+    go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
+      = rnHsBndrSig True doc bsig $ \ bsig' ->
+        go vars ns $ \ vars' ->
+        thing_inside (RuleBndrSig (L loc n) bsig' : vars')
+
+    go [] [] thing_inside = thing_inside []
+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
 \end{code}
 
 Note [Rule LHS validity checking]
@@ -628,6 +631,12 @@ validRuleLhs foralls lhs
     checkl_es es = foldr (mplus . checkl_e) Nothing es
 -}
 
+badRuleVar :: FastString -> Name -> SDoc
+badRuleVar name var
+  = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
+        ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
+               ptext (sLit "does not appear on left hand side")]
+
 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 badRuleLhsErr name lhs bad_e
   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
@@ -685,8 +694,8 @@ rnHsVectDecl (HsVectClassIn cls)
 rnHsVectDecl (HsVectClassOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
 rnHsVectDecl (HsVectInstIn instTy)
-  = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
-       ; return (HsVectInstIn instTy', extractHsTyNames instTy')
+  = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
+       ; return (HsVectInstIn instTy', fvs)
        }
 rnHsVectDecl (HsVectInstOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
@@ -772,9 +781,10 @@ rnTyClDecls extra_deps tycl_ds
        ; return (map flattenSCC sccs, all_fvs) }
 
 
-rnTyClDecl :: Maybe Name  -- Just cls => this TyClDecl is nested 
-                         --             inside an *instance decl* for cls
-                         --             used for associated types
+rnTyClDecl :: Maybe (Name, [Name])  
+                    -- Just (cls,tvs) => this TyClDecl is nested 
+                    --             inside an *instance decl* for cls
+                    --             used for associated types
            -> TyClDecl RdrName 
            -> RnM (TyClDecl Name, FreeVars)
 rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
@@ -786,16 +796,15 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- and "data family"), both top level and (for an associated type) 
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
-                            , tcdFlavour = flav, tcdKind = kind })
-  = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' ->
+                            , tcdFlavour = flav, tcdKindSig = kind })
+  = bindTyClTyVars fmly_doc mb_cls tyvars $ \tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; kind' <- rnLHsMaybeKind fmly_doc kind
-       ; let fv_kind = maybe emptyFVs extractHsTyNames kind'
-             fvs = extractHsTyVarBndrNames_s tyvars' fv_kind
+       ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
-                           , tcdFlavour = flav, tcdKind = kind' }
-                , fvs) }
-  where fmly_doc = TyFamilyCtx tycon
+                           , tcdFlavour = flav, tcdKindSig = kind' }
+                , fv_kind) }
+  where 
+     fmly_doc = TyFamilyCtx tycon
 
 -- "data", "newtype", "data instance, and "newtype instance" declarations
 -- both top level and (for an associated type) in an instance decl
@@ -804,40 +813,35 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
                                 tcdLName = tycon, tcdTyVars = tyvars, 
                                 tcdTyPats = typats, tcdCons = condecls, 
                                 tcdKindSig = sig, tcdDerivs = derivs}
-  = do { tycon' <- lookupTcdName mb_cls tydecl
-        ; sig' <- rnLHsMaybeKind data_doc sig
+  = bindTyClTyVars data_doc mb_cls tyvars $ \ tyvars' ->
+                                -- Checks for distinct tyvars
+    do { tycon' <- lookupTcdName (fmap fst mb_cls) tydecl
        ; checkTc (h98_style || null (unLoc context)) 
                   (badGadtStupidTheta tycon)
 
-       ; ((tyvars', context', typats', derivs'), stuff_fvs)
-               <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do
-                                -- Checks for distinct tyvars
-                  { context' <- rnContext data_doc context
-                   ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
-                   ; (derivs', fvs2) <- rn_derivs derivs
-                   ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
-                               extractHsCtxtTyNames context'
-                               `plusFV` maybe emptyFVs extractHsTyNames sig'
-                  ; return ((tyvars', context', typats', derivs'), fvs) }
-
-       -- For the constructor declarations, bring into scope the tyvars 
-       -- bound by the header, but *only* in the H98 case
-       -- Reason: for GADTs, the type variables in the declaration 
-       --   do not scope over the constructor signatures
-       --   data T a where { T1 :: forall b. b-> b }
-        ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
-                              | otherwise = []
-       ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
+        ; (sig', sig_fvs)  <- rnLHsMaybeKind data_doc sig
+        ; (context', fvs1) <- rnContext data_doc context
+        ; (typats',  fvs2) <- rnTyPats data_doc tycon' typats
+        ; (derivs',  fvs3) <- rn_derivs derivs
+
+       -- For the constructor declarations, drop the LocalRdrEnv
+        -- in the GADT case, where the type variables in the declaration 
+       -- do not scope over the constructor signatures
+       -- data T a where { T1 :: forall b. b-> b }
+        ; let { zap_lcl_env | h98_style = \ thing -> thing
+                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
+       ; (condecls', con_fvs) <- zap_lcl_env $
                                   rnConDecls condecls
-               -- No need to check for duplicate constructor decls
-               -- since that is done by RnNames.extendGlobalRdrEnvRn
-
-       ; return (TyData {tcdND = new_or_data, tcdCType = cType,
-               tcdCtxt = context', 
-                          tcdLName = tycon', tcdTyVars = tyvars', 
-                          tcdTyPats = typats', tcdKindSig = sig',
-                          tcdCons = condecls', tcdDerivs = derivs'}, 
-                  con_fvs `plusFV` stuff_fvs)
+           -- No need to check for duplicate constructor decls
+          -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+       ; return ( TyData { tcdND = new_or_data, tcdCType = cType
+                          , tcdCtxt = context' 
+                          , tcdLName = tycon', tcdTyVars = tyvars' 
+                         , tcdTyPats = typats', tcdKindSig = sig'
+                         , tcdCons = condecls', tcdDerivs = derivs'} 
+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV`
+                  con_fvs `plusFV` sig_fvs )
         }
   where
     h98_style = case condecls of        -- Note [Stupid theta]
@@ -847,22 +851,23 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
     data_doc = TyDataCtx tycon
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
-    rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds
-                            ; return (Just ds', extractHsTyNames_s ds') }
+    rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds
+                            ; return (Just ds', fvs) }
 
 -- "type" and "type instance" declarations
-rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars,
-                          tcdLName = name,
-                                     tcdTyPats = typats, tcdSynRhs = ty})
-  = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
-    {           -- Checks for distinct tyvars
-      name' <- lookupTcdName mb_cls tydecl
-    ; (typats',fvs1) <- rnTyPats syn_doc name' typats
-    ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
-    ; return (TySynonym { tcdLName = name'
-                , tcdTyVars = tyvars'
-                       , tcdTyPats = typats', tcdSynRhs = ty'}
-             , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
+rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars
+                                    , tcdLName = name
+                                   , tcdTyPats = typats, tcdSynRhs = ty})
+  = do { name' <- lookupTcdName (fmap fst mb_cls) tydecl
+       ; ((tyvars', typats', ty'), fvs) 
+            <- bindTyClTyVars syn_doc mb_cls tyvars $ \ tyvars' -> do
+               do { (typats',fvs1) <- rnTyPats syn_doc name' typats
+                  ; (ty', fvs2)    <- rnLHsType syn_doc ty
+                  ; return ((tyvars', typats', ty'), fvs1 `plusFV` fvs2) }
+       ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
+                                  , tcdTyPats = typats', tcdSynRhs = ty'
+                           , tcdFVs = fvs }
+                , fvs) }
   where
     syn_doc = TySynCtx name
 
@@ -875,19 +880,19 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 
        -- Tyvars scope over superclass context and method signatures
        ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-           <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do
+           <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do
                 -- Checks for distinct tyvars
-            { context' <- rnContext cls_doc context
+            { (context', cxt_fvs) <- rnContext cls_doc context
             ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
-             ; let rn_at = rnTyClDecl (Just cls')
-             ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
-            ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
-             ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs
-            ; let fvs = extractHsCtxtTyNames context'  `plusFV`
-                        hsSigsFVs sigs'                `plusFV`
-                         plusFVs fv_ats                 `plusFV`
-                         plusFVs fv_at_defs
                         -- The fundeps have no free variables
+             ; let tv_ns = hsLTyVarNames tyvars'
+             ; (ats',     fv_ats)     <- rnATDecls cls' tv_ns ats
+             ; (at_defs', fv_at_defs) <- rnATDecls cls' tv_ns at_defs
+            ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
+            ; let fvs = cxt_fvs     `plusFV`
+                        sig_fvs     `plusFV`
+                         fv_ats      `plusFV`
+                         fv_at_defs
             ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) }
 
        -- No need to check for duplicate associated type decls
@@ -924,64 +929,11 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
                              tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
                               tcdDocs = docs'},
-                 extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) }
+                 meth_fvs `plusFV` stuff_fvs) }
   where
     cls_doc  = ClassDeclCtx lcls
 
 
-bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName]
-         -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-         -> RnM (a, FreeVars)
-bindQTvs doc mb_cls tyvars thing_inside
-  | isNothing mb_cls    -- Not associated
-  = bindTyVarsFV doc tyvars thing_inside
-  | otherwise          -- Associated
-  = do { let tv_rdr_names = map hsLTyVarLocName tyvars
-                    -- *All* the free vars of the family patterns
-
-       -- Check for duplicated bindings
-       -- This test is irrelevant for data/type *instances*, where the tyvars
-       -- are the free tyvars of the patterns, and hence have no duplicates
-       -- But it's needed for data/type *family* decls
-       ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names)
-
-       ; rdr_env <- getLocalRdrEnv
-
-       ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names
-       ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns
-       ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars'
-
-       -- Check that the RHS of the decl mentions only type variables
-       -- bound on the LHS.  For example, this is not ok
-       --       class C a b where
-       --         type F a x :: *
-       --       instance C (p,q) r where
-        --        type F (p,q) x = (x, r)      -- BAD: mentions 'r'
-       -- c.f. Trac #5515
-       ; let bad_tvs = filterNameSet (isTvOcc . nameOccName) fvs
-       ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
-
-       ; return (thing, fvs) }
-  where
-    mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM Name
-    mk_tv_name rdr_env (L l tv_rdr)
-      = case lookupLocalRdrEnv rdr_env tv_rdr of 
-          Just n  -> return n
-          Nothing -> newLocalBndrRn (L l tv_rdr)
-
-badAssocRhs :: [Name] -> RnM ()
-badAssocRhs ns
-  = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
-                  <> plural ns 
-                  <+> pprWithCommas (quotes . ppr) ns)
-               2 (ptext (sLit "All such variables must be bound on the LHS")))
-
-dupBoundTyVar :: [Located RdrName] -> RnM ()
-dupBoundTyVar (L loc tv : _) 
-  = setSrcSpan loc $
-    addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv))
-dupBoundTyVar [] = panic "dupBoundTyVar"
-
 badGadtStupidTheta :: Located RdrName -> SDoc
 badGadtStupidTheta _
   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
@@ -1049,24 +1001,22 @@ is jolly confusing.  See Trac #4875
 %*********************************************************
 
 \begin{code}
-rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
+rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] 
+         -> RnM (Maybe [LHsType Name], FreeVars)
 -- Although, we are processing type patterns here, all type variables will
 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 -- type declaration to which these patterns belong)
 rnTyPats _   _  Nothing
   = return (Nothing, emptyFVs)
 rnTyPats doc tc (Just typats) 
-  = do { typats' <- rnLHsTypes doc typats
-       ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
+  = do { (typats', fvs) <- rnLHsTypes doc typats
+       ; return (Just typats', addOneFV fvs (unLoc tc)) }
                     -- type instance => use, hence addOneFV
-       ; return (Just typats', fvs) }
 
 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
-rnConDecls condecls
-  = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
-       ; return (condecls', plusFVs (map conDeclFVs condecls')) }
+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
-rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
+rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
                        , con_cxt = cxt, con_details = details
                        , con_res = res_ty, con_doc = mb_doc
@@ -1094,24 +1044,25 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
-       { new_context <- rnContext doc cxt
-       ; new_details <- rnConDeclDetails doc details
-        ; (new_details', new_res_ty <- rnConResult doc (unLoc new_name) new_details res_ty
+        ; bindHsTyVars doc new_tvs $ \new_tyvars -> do
+       { (new_context, fvs1) <- rnContext doc cxt
+       ; (new_details, fvs2) <- rnConDeclDetails doc details
+        ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
-                       , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
+                       , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' },
+                  fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
  where
     doc = ConDeclCtx name
     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys))
 
 rnConResult :: HsDocContext -> Name
             -> HsConDetails (LHsType Name) [ConDeclField Name]
-            -> ResType RdrName
+            -> ResType (LHsType RdrName)
             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
-                    ResType Name)
-rnConResult _   _   details ResTyH98 = return (details, ResTyH98)
+                    ResType (LHsType Name), FreeVars)
+rnConResult _   _   details ResTyH98 = return (details, ResTyH98, emptyFVs)
 rnConResult doc con details (ResTyGADT ty)
-  = do { ty' <- rnLHsType doc ty
+  = do { (ty', fvs) <- rnLHsType doc ty
        ; let (arg_tys, res_ty) = splitHsFunType ty'
                -- We can finally split it up, 
                -- now the renamer has dealt with fixities
@@ -1123,7 +1074,7 @@ rnConResult doc con details (ResTyGADT ty)
 
                   RecCon {}    -> do { unless (null arg_tys) 
                                        (addErr (badRecResTy (docOfHsDocContext doc)))
-                              ; return (details, ResTyGADT res_ty) }
+                              ; return (details, ResTyGADT res_ty, fvs) }
 
           PrefixCon {} | isSymOcc (getOccName con)  -- See Note [Infix GADT cons]
                         , [ty1,ty2] <- arg_tys
@@ -1131,27 +1082,27 @@ rnConResult doc con details (ResTyGADT ty)
                               ; return (if   con `elemNameEnv` fix_env 
                                         then InfixCon ty1 ty2
                                         else PrefixCon arg_tys
-                                       , ResTyGADT res_ty) }
+                                       , ResTyGADT res_ty, fvs) }
                         | otherwise
-                        -> return (PrefixCon arg_tys, ResTyGADT res_ty) }
+                        -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
 
 rnConDeclDetails :: HsDocContext
                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
-                 -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
+                 -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars)
 rnConDeclDetails doc (PrefixCon tys)
-  = do { new_tys <- mapM (rnLHsType doc) tys
-       ; return (PrefixCon new_tys) }
+  = do { (new_tys, fvs) <- rnLHsTypes doc tys
+       ; return (PrefixCon new_tys, fvs) }
 
 rnConDeclDetails doc (InfixCon ty1 ty2)
-  = do { new_ty1 <- rnLHsType doc ty1
-       ; new_ty2 <- rnLHsType doc ty2
-       ; return (InfixCon new_ty1 new_ty2) }
+  = do { (new_ty1, fvs1) <- rnLHsType doc ty1
+       ; (new_ty2, fvs2) <- rnLHsType doc ty2
+       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
 
 rnConDeclDetails doc (RecCon fields)
-  = do { new_fields <- rnConDeclFields doc fields
+  = do { (new_fields, fvs) <- rnConDeclFields doc fields
                -- No need to check for duplicate fields
                -- since that is done by RnNames.extendGlobalRdrEnvRn
-       ; return (RecCon new_fields) }
+       ; return (RecCon new_fields, fvs) }
 
 -------------------------------------------------
 deprecRecSyntax :: ConDecl RdrName -> SDoc
index 3b86d0b..15e5501 100644 (file)
@@ -15,7 +15,7 @@ module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
-       rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields,
+       rnHsSigType, rnLHsInstType, rnConDeclFields,
         rnIPName,
 
        -- Precence related stuff
@@ -26,7 +26,7 @@ module RnTypes (
        rnSplice, checkTH,
 
         -- Binding related stuff
-        bindTyVarsRn, bindTyVarsFV
+        bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -36,8 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
 
 import DynFlags
 import HsSyn
-import RdrHsSyn                ( extractHsRhoRdrTyVars )
-import RnHsSyn         ( extractHsTyNames, extractHsTyVarBndrNames_s )
+import RdrHsSyn                ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars )
 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import TcRnMonad
@@ -54,7 +53,7 @@ import BasicTypes     ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
                          Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
-import Control.Monad   ( unless, zipWithM )
+import Control.Monad   ( unless )
 
 #include "HsVersions.h"
 \end{code}
@@ -69,23 +68,17 @@ to break several loop.
 %*********************************************************
 
 \begin{code}
-rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnHsTypeFVs doc_str ty  = do
-    ty' <- rnLHsType doc_str ty
-    return (ty', extractHsTyNames ty')
-
-rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
+rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty
-  = rnLHsType (TypeSigCtx doc_str) ty
+rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
 
-rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 -- Rename the type in an instance or standalone deriving decl
 rnLHsInstType doc_str ty 
-  = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty
+  = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty
        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
-       ; return ty' }
+       ; return (ty', fvs) }
   where
     good_inst_ty
       | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
@@ -101,27 +94,34 @@ want a gratuitous knot.
 
 \begin{code}
 rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
-           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
-rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc)
+           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnLHsTyKi isType doc (L loc ty)
+  = setSrcSpan loc $ 
+    do { (ty', fvs) <- rnHsTyKi isType doc ty
+       ; return (L loc ty', fvs) }
 
-rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 rnLHsType = rnLHsTyKi True
-rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name)
+
+rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
 rnLHsKind = rnLHsTyKi False
-rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name))
-rnLHsMaybeKind _ Nothing = return Nothing
-rnLHsMaybeKind doc (Just k) = do
-  k' <- rnLHsKind doc k
-  return (Just k')
 
-rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name)
+rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName) 
+                -> RnM (Maybe (LHsKind Name), FreeVars)
+rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs)
+rnLHsMaybeKind doc (Just k) 
+  = do { (k', fvs) <- rnLHsKind doc k
+       ; return (Just k', fvs) }
+
+rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsType = rnHsTyKi True
-rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name)
+rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
 rnHsKind = rnHsTyKi False
 
-rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name)
+rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 
-rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do
+rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) 
+  = ASSERT ( isType ) do
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
@@ -146,14 +146,11 @@ rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
        ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
 
-       ; -- rnForAll does the rest
-         rnForAll doc Explicit forall_tyvars ctxt tau }
+       ; rnForAll doc Explicit forall_tyvars ctxt tau }
 
-rnHsTyKi isType _ (HsTyVar rdr_name) = do
-  -- We use lookupOccRn in kinds because all the names are in
-  -- TcClsName, and we don't want to look in DataName.
-  name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name
-  return (HsTyVar name)
+rnHsTyKi isType _ (HsTyVar rdr_name)
+  = do { name <- rnTyVar isType rdr_name
+       ; return (HsTyVar name, unitFV name) }
 
 -- If we see (forall a . ty), without foralls on, the forall will give
 -- a sensible error message, but we don't want to complain about the dot too
@@ -162,118 +159,144 @@ rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
   = ASSERT ( isType ) setSrcSpan loc $ 
     do { ops_ok <- xoptM Opt_TypeOperators
        ; op' <- if ops_ok
-                then lookupPromotedOccRn op
+                then rnTyVar isType op
                 else do { addErr (opTyErr op ty)
                         ; return (mkUnboundName op) }  -- Avoid double complaint
        ; let l_op' = L loc op'
        ; fix <- lookupTyFixityRn l_op'
-       ; ty1' <- rnLHsType doc ty1
-       ; ty2' <- rnLHsType doc ty2
-       ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' }
+       ; (ty1', fvs1) <- rnLHsType doc ty1
+       ; (ty2', fvs2) <- rnLHsType doc ty2
+       ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) 
+                               op' fix ty1' ty2'
+        ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
 
-rnHsTyKi isType doc (HsParTy ty) = do
-    ty' <- rnLHsTyKi isType doc ty
-    return (HsParTy ty')
+rnHsTyKi isType doc (HsParTy ty)
+  = do { (ty', fvs) <- rnLHsTyKi isType doc ty
+       ; return (HsParTy ty', fvs) }
 
 rnHsTyKi isType doc (HsBangTy b ty)
-  = ASSERT ( isType ) do { ty' <- rnLHsType doc ty
-       ; return (HsBangTy b ty') }
+  = ASSERT ( isType ) 
+    do { (ty', fvs) <- rnLHsType doc ty
+       ; return (HsBangTy b ty', fvs) }
 
 rnHsTyKi isType doc (HsRecTy flds)
-  = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds
-       ; return (HsRecTy flds') }
+  = ASSERT ( isType ) 
+    do { (flds', fvs) <- rnConDeclFields doc flds
+       ; return (HsRecTy flds', fvs) }
 
-rnHsTyKi isType doc (HsFunTy ty1 ty2) = do
-    ty1' <- rnLHsTyKi isType doc ty1
+rnHsTyKi isType doc (HsFunTy ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
        -- Might find a for-all as the arg of a function type
-    ty2' <- rnLHsTyKi isType doc ty2
+       ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
 
        -- Check for fixity rearrangements
-    if isType
-      then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
-      else return (HsFunTy ty1' ty2')
+       ; res_ty <- if isType
+                   then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+                   else return (HsFunTy ty1' ty2')
+       ; return (res_ty, fvs1 `plusFV` fvs2) }
 
-rnHsTyKi isType doc listTy@(HsListTy ty) = do
-    data_kinds <- xoptM Opt_DataKinds
-    unless (data_kinds || isType) (addErr (dataKindsErr listTy))
-    ty' <- rnLHsTyKi isType doc ty
-    return (HsListTy ty')
+rnHsTyKi isType doc listTy@(HsListTy ty)
+  = do { data_kinds <- xoptM Opt_DataKinds
+       ; unless (data_kinds || isType) (addErr (dataKindsErr listTy))
+       ; (ty', fvs) <- rnLHsTyKi isType doc ty
+       ; return (HsListTy ty', fvs) }
 
 rnHsTyKi isType doc (HsKindSig ty k)
-  = ASSERT ( isType ) do { 
-       ; kind_sigs_ok <- xoptM Opt_KindSignatures
-       ; unless kind_sigs_ok (addErr (kindSigErr ty))
-       ; ty' <- rnLHsType doc ty
-       ; k' <- rnLHsKind doc k
-       ; return (HsKindSig ty' k') }
+  = ASSERT ( isType ) 
+    do { kind_sigs_ok <- xoptM Opt_KindSignatures
+       ; unless kind_sigs_ok (badSigErr False doc ty)
+       ; (ty', fvs1) <- rnLHsType doc ty
+       ; (k', fvs2) <- rnLHsKind doc k
+       ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do
-    ty' <- rnLHsType doc ty
-    return (HsPArrTy ty')
+rnHsTyKi isType doc (HsPArrTy ty) 
+  = ASSERT ( isType )
+    do { (ty', fvs) <- rnLHsType doc ty
+       ; return (HsPArrTy ty', fvs) }
 
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
-    data_kinds <- xoptM Opt_DataKinds
-    unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
-    tys' <- mapM (rnLHsTyKi isType doc) tys
-    return (HsTupleTy tup_con tys')
-
-rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
-    ty1' <- rnLHsTyKi isType doc ty1
-    ty2' <- rnLHsTyKi isType doc ty2
-    return (HsAppTy ty1' ty2')
-
-rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do
-    ty' <- rnLHsType doc ty
-    n' <- rnIPName n
-    return (HsIParamTy n' ty')
-
-rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do
-    ty1' <- rnLHsType doc ty1
-    ty2' <- rnLHsType doc ty2
-    return (HsEqTy ty1' ty2')
+rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
+  = do { data_kinds <- xoptM Opt_DataKinds
+       ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
+       ; return (HsTupleTy tup_con tys', fvs) }
+
+rnHsTyKi isType doc (HsAppTy ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
+       ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
+       ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
+
+rnHsTyKi isType doc (HsIParamTy n ty)
+  = ASSERT( isType )
+    do { (ty', fvs) <- rnLHsType doc ty
+       ; n' <- rnIPName n
+       ; return (HsIParamTy n' ty', fvs) }
+
+rnHsTyKi isType doc (HsEqTy ty1 ty2) 
+  = ASSERT( isType )
+    do { (ty1', fvs1) <- rnLHsType doc ty1
+       ; (ty2', fvs2) <- rnLHsType doc ty2
+       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
 
 rnHsTyKi isType _ (HsSpliceTy sp _ k)
-  = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp   -- ToDo: deal with fvs
-       ; return (HsSpliceTy sp' fvs k) }
+  = ASSERT ( isType ) 
+    do { (sp', fvs) <- rnSplice sp     -- ToDo: deal with fvs
+       ; return (HsSpliceTy sp' fvs k, fvs) }
 
-rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do
-    ty' <- rnLHsType doc ty
-    haddock_doc' <- rnLHsDoc haddock_doc
-    return (HsDocTy ty' haddock_doc')
+rnHsTyKi isType doc (HsDocTy ty haddock_doc) 
+  = ASSERT ( isType )
+    do { (ty', fvs) <- rnLHsType doc ty
+       ; haddock_doc' <- rnLHsDoc haddock_doc
+       ; return (HsDocTy ty' haddock_doc', fvs) }
 
 #ifndef GHCI
 rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
 #else
-rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq
-                                      ; rnHsType doc (unLoc ty) }
+rnHsTyKi isType doc (HsQuasiQuoteTy qq) 
+  = ASSERT ( isType ) 
+    do { ty <- runQuasiQuoteType qq
+       ; rnHsType doc (unLoc ty) }
 #endif
-rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty)
-rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi"
 
-rnHsTyKi isType doc (HsExplicitListTy k tys) = 
-  ASSERT( isType )
-  do tys' <- mapM (rnLHsType doc) tys
-     return (HsExplicitListTy k tys')
+rnHsTyKi isType _ (HsCoreTy ty) 
+  = ASSERT ( isType ) 
+    return (HsCoreTy ty, emptyFVs)
+    -- The emptyFVs probably isn't quite right 
+    -- but I don't think it matters
+
+rnHsTyKi _ _ (HsWrapTy {}) 
+  = panic "rnHsTyKi"
+
+rnHsTyKi isType doc (HsExplicitListTy k tys)
+  = ASSERT( isType )
+    do { (tys', fvs) <- rnLHsTypes doc tys
+       ; return (HsExplicitListTy k tys', fvs) }
+
+rnHsTyKi isType doc (HsExplicitTupleTy kis tys) 
+  = ASSERT( isType )
+    do { (tys', fvs) <- rnLHsTypes doc tys
+       ; return (HsExplicitTupleTy kis tys', fvs) }
 
-rnHsTyKi isType doc (HsExplicitTupleTy kis tys) =
-  ASSERT( isType )
-  do tys' <- mapM (rnLHsType doc) tys
-     return (HsExplicitTupleTy kis tys')
+--------------
+rnTyVar :: Bool -> RdrName -> RnM Name
+rnTyVar is_type rdr_name
+  | is_type   = lookupTypeOccRn rdr_name
+  | otherwise = lookupKindOccRn rdr_name
 
 --------------
 rnLHsTypes :: HsDocContext -> [LHsType RdrName]
-           -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
-rnLHsTypes doc tys = mapM (rnLHsType doc) tys
+           -> RnM ([LHsType Name], FreeVars)
+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
 \end{code}
 
 
 \begin{code}
 rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
-        -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
+        -> LHsContext RdrName -> LHsType RdrName 
+         -> RnM (HsType Name, FreeVars)
 
 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
        -- One reason for this case is that a type like Int#
@@ -285,48 +308,190 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
        -- of kind *.
 
 rnForAll doc exp forall_tyvars ctxt ty
-  = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
-    new_ctxt <- rnContext doc ctxt
-    new_ty <- rnLHsType doc ty
-    return (HsForAllTy exp new_tyvars new_ctxt new_ty)
+  = bindHsTyVars doc forall_tyvars $ \ new_tyvars ->
+    do { (new_ctxt, fvs1) <- rnContext doc ctxt
+       ; (new_ty, fvs2) <- rnLHsType doc ty
+       ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
        -- Retain the same implicit/explicit flag as before
        -- so that we can later print it correctly
 
-bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName]
+---------------
+bindSigTyVarsFV :: [Name]
+               -> RnM (a, FreeVars)
+               -> RnM (a, FreeVars)
+-- Used just before renaming the defn of a function
+-- with a separate type signature, to bring its tyvars into scope
+-- With no -XScopedTypeVariables, this is a no-op
+bindSigTyVarsFV tvs thing_inside
+  = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
+       ; if not scoped_tyvars then 
+               thing_inside 
+         else
+               bindLocalNamesFV tvs thing_inside }
+
+---------------
+bindTyClTyVars 
+    :: HsDocContext 
+    -> Maybe (Name, [Name])      -- Parent class and its tyvars
+                                 -- (but not kind vars)
+    -> [LHsTyVarBndr RdrName]
+    -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+    -> RnM (a, FreeVars)
+-- Used for tyvar binders in type/class declarations
+-- Just like bindHsTyVars, but deals with the case of associated
+-- types, where the type variables may be already in scope
+bindTyClTyVars doc mb_cls tyvars thing_inside
+  | Just (_, cls_tvs) <- mb_cls   -- Associated type family or type instance
+  = do { let tv_rdr_names = map hsLTyVarLocName tyvars
+                    -- *All* the free vars of the family patterns
+
+       -- Check for duplicated bindings
+       -- This test is irrelevant for data/type *instances*, where the tyvars
+       -- are the free tyvars of the patterns, and hence have no duplicates
+       -- But it's needed for data/type *family* decls
+       ; checkDupRdrNames tv_rdr_names
+
+       -- Make the Names for the tyvars
+       ; rdr_env <- getLocalRdrEnv
+       ; let mk_tv_name :: Located RdrName -> RnM Name
+              -- Use the same Name as the parent class decl
+             mk_tv_name (L l tv_rdr)
+               = case lookupLocalRdrEnv rdr_env tv_rdr of 
+                    Just n  -> return n
+                    Nothing -> newLocalBndrRn (L l tv_rdr)
+       ; tv_ns <- mapM mk_tv_name tv_rdr_names
+
+       ; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside
+
+            -- See Note [Renaming associated types] 
+       ; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs
+       ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
+
+       ; return (thing, fvs) }
+
+  | otherwise   -- Not associated, just fall through to bindHsTyVars
+  = bindHsTyVars doc tyvars thing_inside
+
+badAssocRhs :: [Name] -> RnM ()
+badAssocRhs ns
+  = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
+                  <> plural ns 
+                  <+> pprWithCommas (quotes . ppr) ns)
+               2 (ptext (sLit "All such variables must be bound on the LHS")))
+
+---------------
+bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
              -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
              -> RnM (a, FreeVars)
-bindTyVarsFV doc tyvars thing_inside
-  = bindTyVarsRn doc tyvars $ \ tyvars' ->
-    do { (res, fvs) <- thing_inside tyvars'
-       ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) }
-
-bindTyVarsRn ::  HsDocContext -> [LHsTyVarBndr RdrName]
-             -> ([LHsTyVarBndr Name] -> RnM a)
-             -> RnM a
--- Haskell-98 binding of type variables; e.g. within a data type decl
-bindTyVarsRn doc tyvar_names enclosed_scope
-  = bindLocatedLocalsRn located_tyvars $ \ names ->
-    do { kind_sigs_ok <- xoptM Opt_KindSignatures
-       ; unless (null kinded_tyvars || kind_sigs_ok)
-           (mapM_ (addErr . kindSigErr) kinded_tyvars)
-       ; tyvar_names' <- zipWithM replace tyvar_names names
-       ; enclosed_scope tyvar_names' }
+bindHsTyVars doc tv_bndrs thing_inside
+  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
+       ; names <- newLocalBndrsRn rdr_names_w_loc
+       ; bindTyVarsRn doc tv_bndrs names thing_inside }
   where
-    replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc
-    located_tyvars = hsLTyVarLocNames tyvar_names
-    kinded_tyvars  = [n | L _ (KindedTyVar n _ _) <- tyvar_names]
+    rdr_names_w_loc = hsLTyVarLocNames tv_bndrs
 
-rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
-rnConDeclFields doc fields = mapM (rnField doc) fields
-
-rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name)
-rnField doc (ConDeclField name ty haddock_doc)
-  = do { new_name <- lookupLocatedTopBndrRn name
-       ; new_ty <- rnLHsType doc ty
-       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
-       ; return (ConDeclField new_name new_ty new_haddock_doc) }
+---------------
+bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name]
+            -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+            -> RnM (a, FreeVars)
+-- Rename the HsTyVarBndrs, giving them the specified names
+-- *and* bringing into scope the kind variables bound in 
+-- any kind signatures
+
+bindTyVarsRn doc tv_bndrs names thing_inside
+  = go tv_bndrs names $ \ tv_bndrs' -> 
+    bindLocalNamesFV names (thing_inside tv_bndrs')
+  where
+    go [] [] thing_inside = thing_inside []
+
+    go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside
+      = go tvs ns $ \ tvs' ->
+        thing_inside (L loc (UserTyVar n tck) : tvs')
+
+    go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside
+      = rnHsBndrSig False doc bsig $ \ bsig' ->
+        go tvs ns $ \ tvs' ->
+        thing_inside (L loc (KindedTyVar n bsig' tck) : tvs')
+
+    -- Lists of unequal length
+    go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
+
+--------------------------------
+rnHsBndrSig :: Bool    -- True <=> type sig, False <=> kind sig
+            -> HsDocContext
+            -> HsBndrSig (LHsType RdrName)
+            -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
+            -> RnM (a, FreeVars)
+rnHsBndrSig is_type doc (HsBSig ty _) thing_inside
+  = do { name_env <- getLocalRdrEnv
+       ; let tv_bndrs  = [ tv | tv <- extractHsTyRdrTyVars ty
+                             , not (unLoc tv `elemLocalRdrEnv` name_env) ]
+
+       ; checkHsBndrFlags is_type doc ty tv_bndrs 
+       ; bindLocatedLocalsFV tv_bndrs $ \ tv_names -> do
+       { (ty', fvs1) <- rnLHsTyKi is_type doc ty
+       ; (res, fvs2) <- thing_inside (HsBSig ty' tv_names)
+       ; return (res, fvs1 `plusFV` fvs2) } }
+
+checkHsBndrFlags :: Bool -> HsDocContext 
+                 -> LHsType RdrName -> [Located RdrName] -> RnM ()
+checkHsBndrFlags is_type doc ty tv_bndrs
+  | is_type     -- Type
+  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
+       ; unless sig_ok (badSigErr True doc ty) }
+  | otherwise   -- Kind
+  = do { sig_ok <- xoptM Opt_KindSignatures
+       ; unless sig_ok (badSigErr False doc ty)
+       ; poly_kind <- xoptM Opt_PolyKinds
+       ; unless (poly_kind || null tv_bndrs) 
+                (addErr (badKindBndrs doc ty tv_bndrs)) }
+
+badKindBndrs :: HsDocContext -> LHsKind RdrName -> [Located RdrName] -> SDoc
+badKindBndrs doc _kind kvs
+  = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
+                 <+> pprQuotedList kvs)
+              2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
+         , docOfHsDocContext doc ]
+
+badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
+badSigErr is_type doc (L loc ty)
+  = setSrcSpan loc $ addErr $
+    vcat [ hang (ptext (sLit "Illegal") <+> what 
+                 <+> ptext (sLit "signature:") <+> quotes (ppr ty))
+              2 (ptext (sLit "Perhaps you intended to use") <+> flag)
+         , docOfHsDocContext doc ]
+  where
+    what | is_type   = ptext (sLit "type")
+         | otherwise = ptext (sLit "kind")
+    flag | is_type   = ptext (sLit "-XScopedTypeVariable")
+         | otherwise = ptext (sLit "-XKindSignatures")
 \end{code}
 
+Note [Renaming associated types] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check that the RHS of the decl mentions only type variables
+bound on the LHS.  For example, this is not ok
+   class C a b where
+      type F a x :: *
+   instance C (p,q) r where
+      type F (p,q) x = (x, r)  -- BAD: mentions 'r'
+c.f. Trac #5515
+
+What makes it tricky is that the *kind* variable from the class *are*
+in scope (Trac #5862):
+    class Category (x :: k -> k -> *) where
+      type Ob x :: k -> Constraint
+      id :: Ob x a => x a a
+      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c 
+Here 'k' is in scope in the kind signature even though it's not 
+explicitly mentioned on the LHS of the type Ob declaration.
+
+We could force you to mention k explicitly, thus
+    class Category (x :: k -> k -> *) where
+      type Ob (x :: k -> k -> *) :: k -> Constraint
+but it seems tiresome to do so.
+
+
 %*********************************************************
 %*                                                     *
 \subsection{Contexts and predicates}
@@ -334,11 +499,21 @@ rnField doc (ConDeclField name ty haddock_doc)
 %*********************************************************
 
 \begin{code}
-rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name)
-rnContext doc = wrapLocM (rnContext' doc)
+rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] 
+                -> RnM ([ConDeclField Name], FreeVars)
+rnConDeclFields doc fields = mapFvRn (rnField doc) fields
+
+rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
+rnField doc (ConDeclField name ty haddock_doc)
+  = do { new_name <- lookupLocatedTopBndrRn name
+       ; (new_ty, fvs) <- rnLHsType doc ty
+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
+       ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
 
-rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name)
-rnContext' doc ctxt = mapM (rnLHsType doc) ctxt
+rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
+rnContext doc (L loc cxt) 
+  = do { (cxt', fvs) <- rnLHsTypes doc cxt
+       ; return (L loc cxt', fvs) }
 
 rnIPName :: IPName RdrName -> RnM (IPName Name)
 rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
index ea1fab7..9ccdfc3 100644 (file)
@@ -121,10 +121,10 @@ lint_binds_help (binder, rhs)
                (mkUnLiftedTyMsg binder rhs)
 
         -- Check match to RHS type
-       -- Actually we *can't* check the RHS type, because
-       -- unsafeCoerce means it really might not match at all
-       -- notably;  eg x::Int = (error @Bool "urk") |> unsafeCoerce...
-       -- case maybe_rhs_ty of
+        -- Actually we *can't* check the RHS type, because
+        -- unsafeCoerce means it really might not match at all
+        -- notably;  eg x::Int = (error @Bool "urk") |> unsafeCoerce...
+        -- case maybe_rhs_ty of
         --  Nothing     -> return ()
         --    Just rhs_ty -> checkTys binder_ty
         --                          rhs_ty
@@ -237,8 +237,8 @@ lintStgAlts alts scrut_ty = do
                            return (Just first_ty)
         where
           -- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-         -- We can't check that the alternatives have the
-         -- same type, becuase they don't, with unsafeCoerce#
+          -- We can't check that the alternatives have the
+          -- same type, becuase they don't, with unsafeCoerce#
 
 lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type)
 lintAlt _ (DEFAULT, _, _, rhs)
@@ -398,8 +398,8 @@ checkFunApp fun_ty arg_tys msg
  where
   (mb_ty, mb_msg) = cfa True fun_ty arg_tys
 
-  cfa :: Bool -> Type -> [Type] -> (Maybe Type         -- Accurate result?
-                                   , Maybe MsgDoc)     -- Errors?
+  cfa :: Bool -> Type -> [Type] -> (Maybe Type          -- Accurate result?
+                                   , Maybe MsgDoc)      -- Errors?
 
   cfa accurate fun_ty []      -- Args have run out; that's fine
       = (if accurate then Just fun_ty else Nothing, Nothing)
@@ -446,12 +446,12 @@ stgEqType orig_ty1 orig_ty2
       | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
       , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
       , let res = if tc1 == tc2 
-                 then equalLength tc_args1 tc_args2 
-                   && and (zipWith go tc_args1 tc_args2)
-                 else  -- TyCons don't match; but don't bleat if either is a 
-                       -- family TyCon because a coercion might have made it 
-                       -- equal to something else
-                   (isFamilyTyCon tc1 || isFamilyTyCon tc2)
+                  then equalLength tc_args1 tc_args2 
+                    && and (zipWith go tc_args1 tc_args2)
+                  else  -- TyCons don't match; but don't bleat if either is a 
+                        -- family TyCon because a coercion might have made it 
+                        -- equal to something else
+                    (isFamilyTyCon tc1 || isFamilyTyCon tc2)
       = if res then True
         else 
         pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1
@@ -459,7 +459,7 @@ stgEqType orig_ty1 orig_ty2
         False
 
       | otherwise = True  -- Conservatively say "fine".  
-                         -- Type variables in particular
+                          -- Type variables in particular
 
 checkInScope :: Id -> LintM ()
 checkInScope id = LintM $ \loc scope errs
index c873c63..1e24a53 100644 (file)
@@ -27,8 +27,8 @@ import Module
 import SrcLoc
 import Outputable
 import UniqFM
+import VarSet
 import FastString
-import VarSet   ( varSetElems )
 import Util( filterOut )
 import Maybes
 import Control.Monad
@@ -174,11 +174,12 @@ tcLookupFamInst tycon tys
   = return Nothing
   | otherwise
   = do { instEnv <- tcGetFamInstEnvs
-       ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv)
-       ; case lookupFamInstEnv instEnv tycon tys of
-          []                      -> return Nothing
+       ; let mb_match = lookupFamInstEnv instEnv tycon tys 
+       ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv)
+       ; case mb_match of
+          [] -> return Nothing
           ((fam_inst, rep_tys):_) 
-             -> return $ Just (fam_inst, rep_tys)
+              -> return $ Just (fam_inst, rep_tys)
        }
 
 tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
@@ -263,18 +264,15 @@ addLocalFamInst (home_fie, my_fis) fam_inst
            -- Load imported instances, so that we report
            -- overlaps correctly
        ; eps <- getEps
-       ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars fam_inst))
        ; let inst_envs  = (eps_fam_inst_env eps, home_fie')
-             conflicts  = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs
              home_fie'' = extendFamInstEnv home_fie fam_inst
 
            -- Check for conflicting instance decls
-       ;  traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs)
-       ; case conflicts of
-            []      ->  return (home_fie'', fam_inst : my_fis')
-            dup : _ ->  do { conflictInstErr fam_inst (fst dup)
-                           ; return (home_fie, my_fis) }
-      }
+       ; no_conflict <- checkForConflicts inst_envs fam_inst
+       ; if no_conflict then
+            return (home_fie'', fam_inst : my_fis')
+         else 
+            return (home_fie,   my_fis) }
 \end{code}
 
 %************************************************************************
@@ -287,8 +285,8 @@ Check whether a single family instance conflicts with those in two instance
 environments (one for the EPS and one for the HPT).
 
 \begin{code}
-checkForConflicts :: FamInstEnvs -> FamInst -> TcM ()
-checkForConflicts inst_envs famInst
+checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
+checkForConflicts inst_envs fam_inst
   = do {       -- To instantiate the family instance type, extend the instance
                -- envt with completely fresh template variables
                -- This is important because the template variables must
@@ -297,11 +295,13 @@ checkForConflicts inst_envs famInst
                -- We use tcInstSkolType because we don't want to allocate
                -- fresh *meta* type variables.  
 
-       ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst))
-       ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
-       ; unless (null conflicts) $
-          conflictInstErr famInst (fst (head conflicts))
-       }
+       ; (_, skol_tvs) <- tcInstSkolTyVars (coAxiomTyVars (famInstAxiom fam_inst))
+       ; let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs
+             no_conflicts = null conflicts
+       ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs)
+       ; unless no_conflicts $
+          conflictInstErr fam_inst (fst (head conflicts))
+       ; return no_conflicts }
 
 conflictInstErr :: FamInst -> FamInst -> TcRn ()
 conflictInstErr famInst conflictingFamInst
index a194d74..0833a7c 100644 (file)
@@ -152,8 +152,7 @@ deeplySkolemise
 deeplySkolemise ty
   | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
   = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
-       ; tvs1 <- tcInstSkolTyVars tvs
-       ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
+       ; (subst, tvs1) <- tcInstSkolTyVars tvs
        ; ev_vars1 <- newEvVars (substTheta subst theta)
        ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
        ; return ( mkWpLams ids1
@@ -219,7 +218,7 @@ instCallConstraints _ [] = return idHsWrapper
 
 instCallConstraints origin (pred : preds)
   | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
-  = do  { traceTc "instCallConstraints" $ ppr (mkEqPred (ty1, ty2))
+  = do  { traceTc "instCallConstraints" $ ppr (mkEqPred ty1 ty2)
         ; co <- unifyType ty1 ty2
        ; co_fn <- instCallConstraints origin preds
         ; return (co_fn <.> WpEvApp (EvCoercion co)) }
index 2934cda..e15b2ad 100644 (file)
@@ -138,7 +138,7 @@ tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
         -- because we're going to apply it to the environment, not
         -- the return value.
-        ; [r_tv] <- tcInstSkolTyVars [alphaTyVar]
+        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
        ; let r_ty = mkTyVarTy r_tv
         ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty
         ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty))
@@ -245,7 +245,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
 tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)      
   = addErrCtxt (cmdCtxt cmd)   $
     do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
-        ; [w_tv]     <- tcInstSkolTyVars [alphaTyVar]
+        ; (_, [w_tv])     <- tcInstSkolTyVars [alphaTyVar]
        ; let w_ty = mkTyVarTy w_tv     -- Just a convenient starting point
 
                --  a ((w,t1) .. tn) t
index 66c3b71..1cc97de 100644 (file)
@@ -6,9 +6,10 @@
 
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
-                 tcHsBootSigs, tcPolyBinds,
+                 tcHsBootSigs, tcPolyBinds, tcPolyCheck,
                  PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
-                 TcSigInfo(..), SigFun, mkSigFun,
+                 TcSigInfo(..), TcSigFun, 
+                 instTcTySig, instTcTySigFromId,
                  badBootDeclErr ) where
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
@@ -82,6 +83,65 @@ type-checking the LHS of course requires that the binder is in scope.
 At the top-level the LIE is sure to contain nothing but constant
 dictionaries, which we resolve at the module level.
 
+Note [Polymorphic recursion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is 
+
+        * Bind any variable for which we have a type signature
+          to an Id with a polymorphic type.  Then when type-checking 
+          the RHSs we'll make a full polymorphic call.
+
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
+
+        f :: Eq a => [a] -> [a]
+        f xs = ...f...
+
+If we don't take care, after typechecking we get
+
+        f = /\a -> \d::Eq a -> let f' = f a d
+                               in
+                               \ys:[a] -> ...f'...
+
+Notice the the stupid construction of (f a d), which is of course
+identical to the function we're executing.  In this case, the
+polymorphic recursion isn't being used (but that's a very common case).
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
+
+        ff :: [Int] -> [Int]
+        ff = f Int dEqInt
+
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
+
+        ff = f Int dEqInt
+
+           = let f' = f Int dEqInt in \ys. ...f'...
+
+           = let f' = let f' = f Int dEqInt in \ys. ...f'...
+                      in \ys. ...f'...
+
+Etc.
+
+NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
+which would make the space leak go away in this case
+
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding.  So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints.  That's what the "lies_avail"
+is doing.
+
+Then we get
+
+        f = /\a -> \d::Eq a -> letrec
+                                 fm = \ys:[a] -> ...fm...
+                               in
+                               fm
+
 \begin{code}
 tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
 -- The TcGblEnv contains the new tcg_binds and tcg_spects
@@ -191,16 +251,9 @@ tcValBinds :: TopLevelFlag
 
 tcValBinds top_lvl binds sigs thing_inside
   = do  {       -- Typecheck the signature
-        ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
-              ; ty_sigs = filter isTypeLSig sigs
-              ; sig_fn  = mkSigFun ty_sigs }
+          (poly_ids, sig_fn) <- tcTySigs sigs
 
-        ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
-                -- No recovery from bad signatures, because the type sigs
-                -- may bind type variables, so proceeding without them
-                -- can lead to a cascade of errors
-                -- ToDo: this means we fall over immediately if any type sig
-                -- is wrong, which is over-conservative, see Trac bug #745
+        ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
 
                 -- Extend the envt right away with all 
                 -- the Ids declared with type signatures
@@ -211,7 +264,7 @@ tcValBinds top_lvl binds sigs thing_inside
         ; return (binds', thing) }
 
 ------------------------
-tcBindGroups :: TopLevelFlag -> SigFun -> PragFun
+tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
              -> [(RecFlag, LHsBinds Name)] -> TcM thing
              -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 -- Typecheck a whole lot of value bindings,
@@ -232,7 +285,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
 
 ------------------------
 tc_group :: forall thing. 
-            TopLevelFlag -> SigFun -> PragFun
+            TopLevelFlag -> TcSigFun -> PragFun
          -> (RecFlag, LHsBinds Name) -> TcM thing
          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
@@ -276,7 +329,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
     tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
 
 ------------------------
-mkEdges :: SigFun -> LHsBinds Name
+mkEdges :: TcSigFun -> LHsBinds Name
         -> [(LHsBind Name, BKey, [BKey])]
 
 type BKey  = Int -- Just number off the bindings
@@ -303,7 +356,7 @@ bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
 bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
 
 ------------------------
-tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun
+tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
             -> RecFlag       -- Whether the group is really recursive
             -> RecFlag       -- Whether it's recursive after breaking
                              -- dependencies based on type signatures
@@ -328,18 +381,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
     { traceTc "------------------------------------------------" empty
     ; traceTc "Bindings for" (ppr binder_names)
 
-    -- Instantiate the polytypes of any binders that have signatures
-    -- (as determined by sig_fn), returning a TcSigInfo for each
-    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
+--    -- Instantiate the polytypes of any binders that have signatures
+--    -- (as determined by sig_fn), returning a TcSigInfo for each
+--    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
 
     ; dflags   <- getDynFlags
     ; type_env <- getLclTypeEnv
     ; let plan = decideGeneralisationPlan dflags type_env 
-                         binder_names bind_list tc_sig_fn
+                         binder_names bind_list sig_fn
     ; traceTc "Generalisation plan" (ppr plan)
     ; result@(_, poly_ids, _) <- case plan of
-         NoGen          -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
-         InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list
+         NoGen          -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list
+         InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list
          CheckGen sig   -> tcPolyCheck sig prag_fn rec_tc bind_list
 
         -- Check whether strict bindings are ok
@@ -390,16 +443,17 @@ tcPolyCheck :: TcSigInfo -> PragFun
 -- There is just one binding, 
 --   it binds a single variable,
 --   it has a signature,
-tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped
-                           , sig_theta = theta, sig_tau = tau })
+tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
+                           , sig_theta = theta, sig_tau = tau, sig_loc = loc })
     prag_fn rec_tc bind_list
-  = do { loc <- getSrcSpanM
-       ; ev_vars <- newEvVars theta
+  = do { ev_vars <- newEvVars theta
        ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
              prag_sigs = prag_fn (idName poly_id)
+       ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped
        ; (ev_binds, (binds', [mono_info])) 
-            <- checkConstraints skol_info tvs ev_vars $
-               tcExtendTyVarEnv2 (scoped `zip` tvs)   $
+            <- setSrcSpan loc $  
+               checkConstraints skol_info tvs ev_vars $
+               tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
                tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
 
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
@@ -747,7 +801,7 @@ scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must b
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 
 -- subsequent error messages
-recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
+recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
 recoveryCode binder_names sig_fn
   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
         ; poly_ids <- mapM mk_dummy binder_names
@@ -945,161 +999,6 @@ getMonoBindInfo tc_binds
 \end{code}
 
 
-%************************************************************************
-%*                                                                      *
-                Generalisation
-%*                                                                      *
-%************************************************************************
-
-unifyCtxts checks that all the signature contexts are the same
-The type signatures on a mutually-recursive group of definitions
-must all have the same context (or none).
-
-The trick here is that all the signatures should have the same
-context, and we want to share type variables for that context, so that
-all the right hand sides agree a common vocabulary for their type
-constraints
-
-We unify them because, with polymorphic recursion, their types
-might not otherwise be related.  This is a rather subtle issue.
-
-\begin{code}
-{-
-unifyCtxts :: [TcSigInfo] -> TcM ()
--- Post-condition: the returned Insts are full zonked
-unifyCtxts [] = return ()
-unifyCtxts (sig1 : sigs)
-  = do  { traceTc "unifyCtxts" (ppr (sig1 : sigs))
-        ; mapM_ unify_ctxt sigs }
-  where
-    theta1 = sig_theta sig1
-    unify_ctxt :: TcSigInfo -> TcM ()
-    unify_ctxt sig@(TcSigInfo { sig_theta = theta })
-        = setSrcSpan (sig_loc sig)                      $
-          addErrCtxt (sigContextsCtxt sig1 sig)         $
-          do { mk_cos <- unifyTheta theta1 theta
-             ; -- Check whether all coercions are identity coercions
-               -- That can happen if we have, say
-               --         f :: C [a]   => ...
-               --         g :: C (F a) => ...
-               -- where F is a type function and (F a ~ [a])
-               -- Then unification might succeed with a coercion.  But it's much
-               -- much simpler to require that such signatures have identical contexts
-               checkTc (isReflMkCos mk_cos)
-                       (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
-             }
-
------------------------------------------------
-sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc
-sigContextsCtxt sig1 sig2
-  = vcat [ptext (sLit "When matching the contexts of the signatures for"), 
-          nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
-                        ppr id2 <+> dcolon <+> ppr (idType id2)]),
-          ptext (sLit "The signature contexts in a mutually recursive group should all be identical")]
-  where
-    id1 = sig_id sig1
-    id2 = sig_id sig2
--}
-\end{code}
-
-
-@getTyVarsToGen@ decides what type variables to generalise over.
-
-For a "restricted group" -- see the monomorphism restriction
-for a definition -- we bind no dictionaries, and
-remove from tyvars_to_gen any constrained type variables
-
-*Don't* simplify dicts at this point, because we aren't going
-to generalise over these dicts.  By the time we do simplify them
-we may well know more.  For example (this actually came up)
-        f :: Array Int Int
-        f x = array ... xs where xs = [1,2,3,4,5]
-We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
-stuff.  If we simplify only at the f-binding (not the xs-binding)
-we'll know that the literals are all Ints, and we can just produce
-Int literals!
-
-Find all the type variables involved in overloading, the
-"constrained_tyvars".  These are the ones we *aren't* going to
-generalise.  We must be careful about doing this:
-
- (a) If we fail to generalise a tyvar which is not actually
-        constrained, then it will never, ever get bound, and lands
-        up printed out in interface files!  Notorious example:
-                instance Eq a => Eq (Foo a b) where ..
-        Here, b is not constrained, even though it looks as if it is.
-        Another, more common, example is when there's a Method inst in
-        the LIE, whose type might very well involve non-overloaded
-        type variables.
-  [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
-        the simple thing instead]
-
- (b) On the other hand, we mustn't generalise tyvars which are constrained,
-        because we are going to pass on out the unmodified LIE, with those
-        tyvars in it.  They won't be in scope if we've generalised them.
-
-So we are careful, and do a complete simplification just to find the
-constrained tyvars. We don't use any of the results, except to
-find which tyvars are constrained.
-
-Note [Polymorphic recursion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The game plan for polymorphic recursion in the code above is 
-
-        * Bind any variable for which we have a type signature
-          to an Id with a polymorphic type.  Then when type-checking 
-          the RHSs we'll make a full polymorphic call.
-
-This fine, but if you aren't a bit careful you end up with a horrendous
-amount of partial application and (worse) a huge space leak. For example:
-
-        f :: Eq a => [a] -> [a]
-        f xs = ...f...
-
-If we don't take care, after typechecking we get
-
-        f = /\a -> \d::Eq a -> let f' = f a d
-                               in
-                               \ys:[a] -> ...f'...
-
-Notice the the stupid construction of (f a d), which is of course
-identical to the function we're executing.  In this case, the
-polymorphic recursion isn't being used (but that's a very common case).
-This can lead to a massive space leak, from the following top-level defn
-(post-typechecking)
-
-        ff :: [Int] -> [Int]
-        ff = f Int dEqInt
-
-Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
-f' is another thunk which evaluates to the same thing... and you end
-up with a chain of identical values all hung onto by the CAF ff.
-
-        ff = f Int dEqInt
-
-           = let f' = f Int dEqInt in \ys. ...f'...
-
-           = let f' = let f' = f Int dEqInt in \ys. ...f'...
-                      in \ys. ...f'...
-
-Etc.
-
-NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
-which would make the space leak go away in this case
-
-Solution: when typechecking the RHSs we always have in hand the
-*monomorphic* Ids for each binding.  So we just need to make sure that
-if (Method f a d) shows up in the constraints emerging from (...f...)
-we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
-to the "givens" when simplifying constraints.  That's what the "lies_avail"
-is doing.
-
-Then we get
-
-        f = /\a -> \d::Eq a -> letrec
-                                 fm = \ys:[a] -> ...fm...
-                               in
-                               fm
 
 %************************************************************************
 %*                                                                      *
@@ -1142,7 +1041,6 @@ However, we do *not* support this
 
     Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec
 
-
 Note [More instantiated than scoped]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There may be more instantiated type variables than lexically-scoped 
@@ -1194,70 +1092,65 @@ For example:
 it's all cool; each signature has distinct type variables from the renamer.)
 
 \begin{code}
-type SigFun = Name -> Maybe ([Name], SrcSpan)
-         -- Maps a let-binder to the list of
-         -- type variables brought into scope
-         -- by its type signature, plus location
-         -- Nothing => no type signature
-
-mkSigFun :: [LSig Name] -> SigFun
--- Search for a particular type signature
--- Precondition: the sigs are all type sigs
--- Precondition: no duplicates
-mkSigFun sigs = lookupNameEnv env
+tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
+tcTySigs hs_sigs
+  = do { ty_sigs <- concat <$> checkNoErrs (mapAndRecoverM tcTySig hs_sigs)
+                -- No recovery from bad signatures, because the type sigs
+                -- may bind type variables, so proceeding without them
+                -- can lead to a cascade of errors
+                -- ToDo: this means we fall over immediately if any type sig
+                -- is wrong, which is over-conservative, see Trac bug #745
+       ; let env = mkNameEnv [(idName (sig_id sig), sig) | sig <- ty_sigs]
+       ; return (map sig_id ty_sigs, lookupNameEnv env) }
+
+tcTySig :: LSig Name -> TcM [TcSigInfo]
+tcTySig (L loc (IdSig id))
+  = do { sig <- instTcTySigFromId loc id
+       ; return [sig] }
+tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty))
+  = setSrcSpan loc $ 
+    do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty
+       ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) }
+tcTySig _ = return []
+
+instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo
+instTcTySigFromId loc id
+  = do { (tvs, theta, tau) <- tcInstType inst_sig_tyvars (idType id)
+       ; return (TcSigInfo { sig_id = id, sig_loc = loc
+                           , sig_tvs = [(Nothing, tv) | tv <- tvs]
+                           , sig_theta = theta, sig_tau = tau }) }
   where
-    env = mkNameEnv (concatMap mk_pair sigs)
-    mk_pair (L loc (IdSig id))              = [(idName id, ([], loc))]
-    mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames
+    -- Hack: in an instance decl we use the selector id as
+    -- the template; but we do *not* want the SrcSpan on the Name of 
+    -- those type variables to refer to the class decl, rather to
+    -- the instance decl 
+    inst_sig_tyvars tvs = tcInstSigTyVars (map set_loc tvs)
+    set_loc tv = setTyVarName tv (mkInternalName (nameUnique n) (nameOccName n) loc)
       where
-        f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc))
-    mk_pair _                               = []
-        -- The scoped names are the ones explicitly mentioned
-        -- in the HsForAll.  (There may be more in sigma_ty, because
-        -- of nested type synonyms.  See Note [More instantiated than scoped].)
-        -- See Note [Only scoped tyvars are in the TyVarEnv]
-\end{code}
+        n = tyVarName tv
+
+instTcTySig :: LHsType Name -> TcType    -- HsType and corresponding TcType
+            -> Name -> TcM TcSigInfo
+instTcTySig hs_ty@(L loc _) sigma_ty name
+  = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
+       ; return (TcSigInfo { sig_id = poly_id, sig_loc = loc
+                           , sig_tvs = zipEqual "instTcTySig" scoped_tvs inst_tvs
+                           , sig_theta = theta, sig_tau = tau }) }
+  where
+    poly_id      = mkLocalId name sigma_ty
 
-\begin{code}
-tcTySig :: LSig Name -> TcM [TcId]
-tcTySig (L span (TypeSig names@(L _ name1 : _) ty))
-  = setSrcSpan span $ 
-    do { sigma_ty <- tcHsSigType (FunSigCtxt name1) ty
-       ; return [ mkLocalId name sigma_ty | L _ name <- names ] }
-tcTySig (L _ (IdSig id))
-  = return [id]
-tcTySig s = pprPanic "tcTySig" (ppr s)
+    scoped_names = hsExplicitTvs hs_ty
+    (sig_tvs,_)  = tcSplitForAllTys sigma_ty
 
--------------------
-tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun
-tcInstSigs sig_fn bndrs
-  = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs
-       ; return (lookupNameEnv (mkNameEnv prs)) }
-  where
-    use_skols = isSingleton bndrs       -- See Note [Signature skolems]
+    scoped_tvs :: [Maybe Name]
+    scoped_tvs = mk_scoped scoped_names sig_tvs
 
-tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo))
--- For use_skols :: Bool see Note [Signature skolems]
---
--- We must instantiate with fresh uniques, 
--- (see Note [Instantiate sig with fresh variables])
--- although we keep the same print-name.
-
-tcInstSig sig_fn use_skols name
-  | Just (scoped_tvs, loc) <- sig_fn name
-  = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into 
-                                        -- scope when starting the binding group
-        ; let poly_ty = idType poly_id
-        ; (tvs, theta, tau) <- if use_skols
-                               then tcInstType tcInstSkolTyVars poly_ty
-                               else tcInstType tcInstSigTyVars  poly_ty
-        ; let sig = TcSigInfo { sig_id = poly_id
-                              , sig_scoped = scoped_tvs
-                              , sig_tvs = tvs, sig_theta = theta, sig_tau = tau
-                              , sig_loc = loc }
-        ; return (Just (name, sig)) } 
-  | otherwise
-  = return Nothing
+    mk_scoped :: [Name] -> [TyVar] -> [Maybe Name]
+    mk_scoped []     tvs      = [Nothing | _ <- tvs]
+    mk_scoped (n:ns) (tv:tvs) 
+           | n == tyVarName tv = Just n  : mk_scoped ns     tvs
+           | otherwise         = Nothing : mk_scoped (n:ns) tvs
+    mk_scoped (n:ns) [] = pprPanic "mk_scoped" (ppr name $$ ppr (n:ns) $$ ppr hs_ty $$ ppr sigma_ty)
 
 -------------------------------
 data GeneralisationPlan 
@@ -1268,7 +1161,8 @@ data GeneralisationPlan
        Bool             --   True <=> bindings mention only variables with closed types
                         --            See Note [Bindings with closed types] in TcRnTypes
 
-  | CheckGen TcSigInfo  -- Explicit generalisation; there is an AbsBinds
+  | CheckGen TcSigInfo  -- One binding with a signature
+                        -- Explicit generalisation; there is an AbsBinds
 
 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
index c765dde..d0323a5 100644 (file)
@@ -939,14 +939,17 @@ emitKindConstraint ct
                 , cc_fun = fn, cc_tyargs = xis1
                 , cc_rhs = xi2 }
           -> emit_kind_constraint ev d fl (mkTyConApp fn xis1) xi2
+
       _   -> continueWith ct 
   where
     emit_kind_constraint eqv d fl ty1 ty2 
-       | compatKind k1 k2 
-       = continueWith ct
+       | compatKind k1 k2    -- True when ty1,ty2 are themselves kinds,
+       = continueWith ct     -- because then k1, k2 are BOX
+       
        | otherwise
-       = do { keqv <- forceNewEvVar kind_co_fl (mkEqPred (k1,k2))
-            ; eqv' <- forceNewEvVar fl (mkEqPred (ty1,ty2))
+       = ASSERT( isKind k1 && isKind k2 )
+         do { keqv <- forceNewEvVar kind_co_fl (mkNakedEqPred superKind k1 k2)
+            ; eqv' <- forceNewEvVar fl (mkTcEqPred ty1 ty2)
             ; _fl <- case fl of
                Wanted {}-> setEvBind eqv
                             (mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl
@@ -955,7 +958,7 @@ emitKindConstraint ct
                Derived {} -> return fl
 
             ; traceTcS "Emitting kind constraint" $
-                  vcat [ ppr keqv <+> dcolon <+> ppr (mkEqPred (k1,k2))
+                  vcat [ ppr keqv <+> dcolon <+> ppr (mkEqPred k1 k2)
                        , ppr eqv, ppr eqv' ] 
             ; addToWork (canEq d kind_co_fl keqv k1 k2) -- Emit kind equality
             ; continueWith (ct { cc_id = eqv' }) }
@@ -1215,7 +1218,7 @@ canEqLeaf d fl eqv s1 s2
          else return Stop 
        }
   | otherwise
-  = do { traceTcS "canEqLeaf" $ ppr (mkEqPred (s1,s2))
+  = do { traceTcS "canEqLeaf" $ ppr (mkEqPred s1 s2)
        ; canEqLeafOriented d fl eqv s1 s2 }
   where
     re_orient = reOrient fl 
@@ -1408,7 +1411,8 @@ canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
 
        ; if no_flattening_happened then
              if isNothing occ_check_result then 
-                 canEqFailure d fl (setVarType eqv $ mkEqPred (mkTyVarTy tv, xi2'))
+                 canEqFailure d fl (setVarType eqv $ 
+                                     mkTcEqPred (mkTyVarTy tv) xi2')
              else 
                  continueWith $ CTyEqCan { cc_id     = eqv
                                          , cc_flavor = fl
index ac1895f..f2f6059 100644 (file)
@@ -16,6 +16,7 @@ Typechecking class declarations
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
                    findMethodBind, instantiateMethod, tcInstanceMethodBody,
                     mkGenericDefMethBind,
+                    HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
                    tcAddDeclCtxt, badMethodErr
                  ) where
 
@@ -98,7 +99,9 @@ tcClassSigs :: Name                -- Name of the class
            -> TcM ([TcMethInfo],    -- Exactly one for each method
                     NameEnv Type)    -- Types of the generic-default methods
 tcClassSigs clas sigs def_methods
-  = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
+  = do { traceTc "tcClassSigs 1" (ppr clas)
+
+       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
        ; let gen_dm_env = mkNameEnv gen_dm_prs
 
        ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
@@ -112,6 +115,7 @@ tcClassSigs clas sigs def_methods
                    | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
                   -- Generic signature without value binding
 
+       ; traceTc "tcClassSigs 2" (ppr clas)
        ; return (op_info, gen_dm_env) }
   where
     vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig    nm ty) <- sigs]
@@ -120,7 +124,9 @@ tcClassSigs clas sigs def_methods
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
     tc_sig genop_env (op_names, op_hs_ty)
-      = do { op_ty <- tcHsType op_hs_ty        -- Class tyvars already in scope
+      = do { traceTc "ClsSig 1" (ppr op_names)
+           ; op_ty <- tcClassSigType op_hs_ty  -- Class tyvars already in scope
+           ; traceTc "ClsSig 2" (ppr op_names)
            ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
            where
              f nm | nm `elemNameEnv` genop_env = GenericDM
@@ -128,7 +134,7 @@ tcClassSigs clas sigs def_methods
                   | otherwise                  = NoDM
 
     tc_gen_sig (op_names, gen_hs_ty)
-      = do { gen_op_ty <- tcHsType gen_hs_ty
+      = do { gen_op_ty <- tcClassSigType gen_hs_ty
            ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
 \end{code}
 
@@ -160,8 +166,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
        ; let
              (tyvars, _, _, op_items) = classBigSig clas
               prag_fn     = mkPragFun sigs default_binds
-             sig_fn      = mkSigFun sigs
-              clas_tyvars = tcSuperSkolTyVars tyvars
+             sig_fn      = mkHsSigFun sigs
+              clas_tyvars = snd (tcSuperSkolTyVars tyvars)
              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
        ; this_dict <- newEvVar pred
 
@@ -178,7 +184,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
     
 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-          -> SigFun -> PragFun -> ClassOpItem
+          -> HsSigFun -> PragFun -> ClassOpItem
           -> TcM (LHsBinds TcId)
 -- Generate code for polymorphic default methods only (hence DefMeth)
 -- (Generic default methods have turned into instance decls by now.)
@@ -186,7 +192,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
 -- default method for every class op, regardless of whether or not 
 -- the programmer supplied an explicit default decl for the class.  
 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
+tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
   = case dm_info of
       NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
                                ; return emptyBag }
@@ -195,7 +201,6 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
   where
     sel_name      = idName sel_id
     prags         = prag_fn sel_name
-    dm_sig_fn  _  = sig_fn sel_name
     dm_bind       = findMethodBind sel_name binds_in
                    `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 
@@ -212,44 +217,44 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
             -- Base the local_dm_name on the selector name, because
             -- type errors from tcInstanceMethodBody come from here
 
-           ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
-                local_dm_id = mkLocalId local_dm_name local_dm_ty
 
            ; dm_id_w_inline <- addInlinePrags dm_id prags
            ; spec_prags     <- tcSpecPrags dm_id prags
 
+           ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
+                 hs_ty       = lookupHsSig hs_sig_fn sel_name 
+                               `orElse` pprPanic "tc_dm" (ppr sel_name)
+
+           ; local_dm_sig <- instTcTySig hs_ty local_dm_ty local_dm_name
            ; warnTc (not (null spec_prags))
                     (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
                      <+> quotes (ppr sel_name))
 
            ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
-                                             dm_id_w_inline local_dm_id dm_sig_fn 
+                                             dm_id_w_inline local_dm_sig
                                              IsDefaultMethod dm_bind
 
            ; return (unitBag tc_bind) }
 
 ---------------
 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-                     -> Id -> Id
-                    -> SigFun -> TcSpecPrags -> LHsBind Name 
+                     -> Id -> TcSigInfo
+                    -> TcSpecPrags -> LHsBind Name 
                     -> TcM (LHsBind Id)
 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
-                     meth_id local_meth_id
-                    meth_sig_fn specs 
-                     (L loc bind)
+                     meth_id local_meth_sig
+                    specs (L loc bind)
   = do {       -- Typecheck the binding, first extending the envt
                -- so that when tcInstSig looks up the local_meth_id to find
                -- its signature, we'll find it in the environment
-          let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
+          let local_meth_id = sig_id local_meth_sig
+              lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
                              -- Substitute the local_meth_name for the binder
                             -- NB: the binding is always a FunBind
-        ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) 
        ; (ev_binds, (tc_bind, _, _)) 
                <- checkConstraints skol_info tyvars dfun_ev_vars $
                  tcExtendIdEnv [local_meth_id] $
-                 tcPolyBinds TopLevel meth_sig_fn no_prag_fn 
-                            NonRecursive NonRecursive
-                            [lm_bind]
+                 tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind]
 
         ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
                            , abe_mono = local_meth_id, abe_prags = specs }
@@ -289,6 +294,20 @@ instantiateMethod clas sel_id inst_tys
 
 
 ---------------------------
+type HsSigFun = NameEnv (LHsType Name)
+
+emptyHsSigs :: HsSigFun
+emptyHsSigs = emptyNameEnv
+
+mkHsSigFun :: [LSig Name] -> HsSigFun
+mkHsSigFun sigs = mkNameEnv [(n, hs_ty) 
+                            | L _ (TypeSig ns hs_ty) <- sigs
+                            , L _ n <- ns ]
+
+lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
+lookupHsSig = lookupNameEnv
+
+---------------------------
 findMethodBind :: Name                 -- Selector name
                -> LHsBinds Name        -- A group of bindings
                -> Maybe (LHsBind Name) -- The binding
index 7751ae4..e8691a4 100644 (file)
@@ -23,6 +23,7 @@ import DynFlags
 import TcRnMonad
 import FamInst
 import TcEnv
+import TcTyClsDecls( tcFamTyPats )
 import TcClassDcl( tcAddDeclCtxt )     -- Small helper
 import TcGenDeriv                      -- Deriv stuff
 import TcGenGenerics
@@ -498,7 +499,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
 -- The deriving clause of a data or newtype declaration
 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
-                                                  tcdTyVars = tv_names,
+                                                  tcdTyVars = hs_tvs,
                                                   tcdTyPats = ty_pats }))
   = setSrcSpan loc     $       -- Use the location of the 'deriving' item
     tcAddDeclCtxt decl $
@@ -512,8 +513,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
 
        -- Given data T a b c = ... deriving( C d ),
        -- we want to drop type variables from T so that (C d (T a)) is well-kinded
-       ; let cls_tyvars = classTyVars cls
-             kind = tyVarKind (last cls_tyvars)
+       ; let cls_tyvars     = classTyVars cls
+             kind           = tyVarKind (last cls_tyvars)
              (arg_kinds, _) = splitKindFunTys kind
              n_args_to_drop = length arg_kinds
              n_args_to_keep = tyConArity tc - n_args_to_drop
@@ -522,7 +523,9 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
              inst_ty_kind   = typeKind inst_ty
              dropped_tvs    = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
              univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
-                                       `minusVarSet` dropped_tvs
+                                            `minusVarSet` dropped_tvs
+  
+        ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
 
        -- Check that the result really is well-kinded
        ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
@@ -556,11 +559,10 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
     get_lhs Nothing     = do { tc <- tcLookupTyCon tycon_name
                             ; let tvs = tyConTyVars tc
                             ; return (tvs, tc, mkTyVarTys tvs) }
-    -- JPM: to fix
-    get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
-                            ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
-                            ; let (tc, tc_args) = tcSplitTyConApp tc_app
-                            ; return (tvs, tc, tc_args) }
+    get_lhs (Just pats) = do { fam_tc <- tcLookupTyCon tycon_name
+                             ; tcFamTyPats fam_tc hs_tvs pats (\_ -> return ()) $
+                                    \ tvs' pats' _ ->
+                               return (tvs', fam_tc, pats') }
 
 deriveTyData _other
   = panic "derivTyData"        -- Caller ensures that only TyData can happen
index a94663e..d97a088 100644 (file)
@@ -25,8 +25,9 @@ module TcEnv(
         tcExtendGhciEnv, tcExtendLetEnv,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
         tcLookup, tcLookupLocated, tcLookupLocalIds, 
-        tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
-        getInLocalScope,
+        tcLookupId, tcLookupTyVar, 
+        tcLookupLcl_maybe, 
+        getScopedTyVarBinds, getInLocalScope,
         wrongThingErr, pprBinders,
 
         tcExtendRecEnv,         -- For knot-tying
@@ -104,29 +105,27 @@ tcLookupGlobal :: Name -> TcM TyThing
 -- In GHCi, we may make command-line bindings (ghci> let x = True)
 -- that bind a GlobalId, but with an InternalName
 tcLookupGlobal name
-  = do  { env <- getGblEnv
-        
-                -- Try local envt
+  = do  {    -- Try local envt
+          env <- getGblEnv
         ; case lookupNameEnv (tcg_type_env env) name of { 
                 Just thing -> return thing ;
-                Nothing    -> do 
+                Nothing    ->
          
-                -- Try global envt
-        { hsc_env <- getTopEnv
-        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
-        ; case mb_thing of  {
-            Just thing -> return thing ;
-            Nothing    -> do
-
                 -- Should it have been in the local envt?
-        { case nameModule_maybe name of
-                Nothing -> notFound name -- Internal names can happen in GHCi
+          case nameModule_maybe name of {
+                Nothing -> notFound name -- Internal names can happen in GHCi
 
                 Just mod | mod == tcg_mod env   -- Names from this module 
-                         -> notFound name -- should be in tcg_type_env
-                         | otherwise
-                         -> tcImportDecl name   -- Go find it in an interface
-        }}}}}
+                         -> notFound name       -- should be in tcg_type_env
+                         | otherwise -> do
+
+           -- Try home package table and external package table
+        { hsc_env <- getTopEnv
+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+        ; case mb_thing of  
+            Just thing -> return thing 
+            Nothing    -> tcImportDecl name   -- Go find it in an interface
+        }}}}
 
 tcLookupField :: Name -> TcM Id         -- Returns the selector Id
 tcLookupField name 
@@ -276,6 +275,11 @@ tcExtendRecEnv gbl_stuff thing_inside
 tcLookupLocated :: Located Name -> TcM TcTyThing
 tcLookupLocated = addLocM tcLookup
 
+tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
+tcLookupLcl_maybe name
+  = do { local_env <- getLclTypeEnv
+       ; return (lookupNameEnv local_env name) }
+
 tcLookup :: Name -> TcM TcTyThing
 tcLookup name = do
     local_env <- getLclTypeEnv
@@ -284,11 +288,11 @@ tcLookup name = do
         Nothing    -> AGlobal <$> tcLookupGlobal name
 
 tcLookupTyVar :: Name -> TcM TcTyVar
-tcLookupTyVar name = do
-    thing <- tcLookup name
-    case thing of
-        ATyVar _ tv -> return tv
-        _           -> pprPanic "tcLookupTyVar" (ppr name)
+tcLookupTyVar name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATyVar _ tv -> return tv
+           _           -> pprPanic "tcLookupTyVar" (ppr name) }
 
 tcLookupId :: Name -> TcM Id
 -- Used when we aren't interested in the binding level, nor refinement. 
@@ -455,7 +459,9 @@ tc_extend_local_env extra_env thing_inside
           NotTopLevel -> id_tvs
       where
         id_tvs = tyVarsOfType (idType id)
-    get_tvs (_, ATyVar _ tv) = unitVarSet tv        -- See Note [Global TyVars]
+    get_tvs (_, ATyVar _ tv)                 -- See Note [Global TyVars]
+      = tyVarsOfType (tyVarKind tv) `extendVarSet` tv 
+      
     get_tvs other = pprPanic "get_tvs" (ppr other)
         
         -- Note [Global TyVars]
@@ -465,6 +471,8 @@ tc_extend_local_env extra_env thing_inside
         -- Here, g mustn't be generalised.  This is also important during
         -- class and instance decls, when we mustn't generalise the class tyvars
         -- when typechecking the methods.
+        --
+        -- Nor must we generalise g over any kind variables free in r's kind
 
 tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
 tcExtendGlobalTyVars gtv_var extra_global_tvs
index cb388ff..79492fe 100644 (file)
@@ -39,13 +39,14 @@ import VarEnv
 import Bag
 import Maybes
 import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
+import SrcLoc           ( noSrcSpan )
 import Util
 import FastString
 import Outputable
 import DynFlags
 import Data.List        ( partition, mapAccumL )
 import Data.Either      ( partitionEithers )
--- import Control.Monad    ( when )
+
 \end{code}
 
 %************************************************************************
@@ -576,7 +577,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2
        -- or there is no context, don't report the context
   = misMatchMsg oriented ty1 ty2
   | otherwise      
-  = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig)
+  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
   where
     givens = getUserGivens ctxt
     orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)
@@ -621,11 +622,14 @@ tyVarExtraInfoMsg implics ty
 
  | otherwise             -- Normal case
  = empty
-
  where
-   ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
-   ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
-                               sep [ppr info, ptext (sLit "at") <+> ppr loc]]
+   ppr_skol given_loc tv_loc
+     = case skol_info of
+         UnkSkol -> ptext (sLit "is an unknown type variable")
+         _ -> sep [ ptext (sLit "is a rigid type variable bound by"),
+                    sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
+     where
+       skol_info = ctLocOrigin given_loc
  
 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 kindErrorMsg ty1 ty2
@@ -938,14 +942,15 @@ mkAmbigMsg ctxt cts
                                    -- if it is not already set!
              ]
 
-getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
+getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc
 -- Get the skolem info for a type variable 
 -- from the implication constraint that binds it
 getSkolemInfo [] tv
   = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
-    UnkSkol
+    CtLoc UnkSkol noSrcSpan []
+
 getSkolemInfo (implic:implics) tv
-  | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic)
+  | tv `elem` ic_skols implic = ic_loc implic
   | otherwise                 = getSkolemInfo implics tv
 
 -----------------------
index d99bd81..b514dc1 100644 (file)
@@ -27,17 +27,14 @@ module TcHsSyn (
        TcId, TcIdSet, 
 
        zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar,
-       zonkId, zonkTopBndrs
+       zonkId, zonkTopBndrs,
+        emptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes
   ) where
 
 #include "HsVersions.h"
 
--- friends:
-import HsSyn   -- oodles of it
-
--- others:
+import HsSyn
 import Id
-
 import TcRnMonad
 import PrelNames
 import TcType
@@ -224,6 +221,9 @@ extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
 extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
   = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env
 
+mkTyVarZonkEnv :: [TyVar] -> ZonkEnv
+mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv
+
 setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
 setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
 
@@ -292,14 +292,12 @@ zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
 zonkTyBndrsX = mapAccumLM zonkTyBndrX 
 
 zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
+-- This guarantees to return a TyVar (not a TcTyVar)
+-- then we add it to the envt, so all occurrences are replaced
 zonkTyBndrX env tv
-  = do { tv' <- zonkTyBndr env tv
-       ; return (extendTyZonkEnv1 env tv', tv') }
-
-zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar
-zonkTyBndr env tv
   = do { ki <- zonkTcTypeToType env (tyVarKind tv)
-       ; return (setVarType tv ki) }
+       ; let tv' = mkTyVar (tyVarName tv) ki
+       ; return (extendTyZonkEnv1 env tv', tv') }
 \end{code}
 
 
@@ -1152,7 +1150,7 @@ zonkEvBind env (EvBind var term)
         | Just ty <- isTcReflCo_maybe co
         ->
           do { zty  <- zonkTcTypeToType env ty
-             ; let var' = setVarType var (mkEqPred (zty,zty))
+             ; let var' = setVarType var (mkEqPred zty zty)
              ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) }
 
       -- Fast path for variable-variable bindings 
@@ -1277,9 +1275,10 @@ zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env)
   = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar)
   where
-    zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of
-                            Nothing  -> mkTyVarTy tv
-                            Just tv' -> mkTyVarTy tv'
+    zonk_bound_tyvar tv    -- Look up in the env just as we do for Ids
+      = case lookupVarEnv tv_env tv of
+          Nothing  -> mkTyVarTy tv
+          Just tv' -> mkTyVarTy tv'
 
 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
index f26bfbb..7394f4f 100644 (file)
 
 module TcHsType (
        tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, 
-       tcHsInstHead, tcHsQuantifiedType,
+       tcHsInstHead, 
        UserTypeCtxt(..), 
 
-               -- Kind checking
-       kcHsTyVars, kcHsSigType, kcHsLiftedSigType, 
-       kcLHsType, kcCheckLHsType, kcHsContext, kcApps,
-        kindGeneralizeKind, kindGeneralizeKinds,
-
-               -- Sort checking
-       scDsLHsKind, scDsLHsMaybeKind,
+                -- Type checking type and class decls
+       kcTyClTyVars, tcTyClTyVars,
+        tcHsConArgType, tcDataKindSig, 
+        tcClassSigType, 
 
-                -- Typechecking kinded types
-       tcHsType, tcCheckHsType,
-        tcHsKindedContext, tcHsKindedType, tcHsBangType,
-       tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType,
-       tcDataKindSig, tcTyClTyVars,
+               -- Kind-checking types
+                -- No kind generalisation, no checkValidType
+       tcHsTyVarBndrs, tcHsTyVarBndrsGen ,
+        tcHsLiftedType, 
+       tcLHsType, tcCheckLHsType, 
+        tcHsContext, tcInferApps, tcHsArgTys,
 
         ExpKind(..), ekConstraint, expArgKind, checkExpectedKind,
+        kindGeneralizeKind, kindGeneralizeKinds,
+
+               -- Sort-checking kinds
+       tcLHsKind, 
 
                -- Pattern type signatures
        tcHsPatSigType, tcPatSig
@@ -40,31 +42,30 @@ module TcHsType (
 #include "HsVersions.h"
 
 #ifdef GHCI    /* Only if bootstrapped */
-import {-# SOURCE #-}  TcSplice( kcSpliceType )
+import {-# SOURCE #-}  TcSplice( tcSpliceType )
 #endif
 
 import HsSyn
-import RnHsSyn
+import TcHsSyn ( zonkTcTypeToType, emptyZonkEnv )
 import TcRnMonad
 import RnEnv   ( dataKindsErr )
-import TcHsSyn ( mkZonkTcTyVar )
 import TcEvidence( HsWrapper )
 import TcEnv
 import TcMType
 import TcUnify
 import TcIface
 import TcType
-import {- Kind parts of -} Type
+import Type
 import Kind
+import TypeRep( mkNakedTyConApp )
 import Var
 import VarSet
 import TyCon
 import DataCon
 import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
 import Class
-import RdrName ( rdrNameSpace, nameRdrName )
 import Name
-import NameSet
+import NameEnv
 import TysWiredIn
 import BasicTypes
 import SrcLoc
@@ -73,7 +74,7 @@ import Util
 import UniqSupply
 import Outputable
 import FastString
-import Control.Monad ( unless )
+import Control.Monad ( unless, when, zipWithM )
 \end{code}
 
 
@@ -155,105 +156,68 @@ the TyCon being defined.
 
 %************************************************************************
 %*                                                                     *
-\subsection{Checking types}
+              Check types AND do validity checking
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
 tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type
-  -- Do kind checking, and hoist for-alls to the top
   -- NB: it's important that the foralls that come from the top-level
   --    HsForAllTy in hs_ty occur *first* in the returned type.
   --     See Note [Scoped] with TcSigInfo
-tcHsSigType ctxt hs_ty 
+tcHsSigType ctxt hs_ty
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
     tcHsSigTypeNC ctxt hs_ty
 
-tcHsSigTypeNC ctxt hs_ty
-  = do  { kinded_ty <- case expectedKindInCtxt ctxt of
-                         Nothing -> fmap fst (kc_lhs_type_fresh hs_ty)
-                         Just k  -> kc_lhs_type hs_ty (EK k (ptext (sLit "Expected")))
+tcHsSigTypeNC ctxt (L loc hs_ty)
+  = setSrcSpan loc $    -- The "In the type..." context
+                        -- comes from the caller; hence "NC"
+    do  { kind <- case expectedKindInCtxt ctxt of
+                    Nothing -> newMetaKindVar
+                    Just k  -> return k
           -- The kind is checked by checkValidType, and isn't necessarily
           -- of kind * in a Template Haskell quote eg [t| Maybe |]
-        ; ty <- tcHsKindedType kinded_ty
-        ; checkValidType ctxt ty
-        ; return ty }
 
--- Like tcHsType, but takes an expected kind
-tcCheckHsType :: LHsType Name -> Kind -> TcM Type
-tcCheckHsType hs_ty exp_kind
-  = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind (ptext (sLit "Expected")))
-       ; ty <- tcHsKindedType kinded_ty
-       ; return ty }
+        ; ty <- tcCheckHsTypeAndGen hs_ty kind
+                -- Generalise here: see Note [Kind generalisation]
 
-tcHsType :: LHsType Name -> TcM Type
--- kind check and desugar
--- no validity checking because of knot-tying
-tcHsType hs_ty
-  = do { (kinded_ty, _) <- kc_lhs_type_fresh hs_ty
-       ; ty <- tcHsKindedType kinded_ty
-       ; return ty }
+          -- Zonk to expose kind information to checkValidType
+        ; ty <- zonkTcType ty
+        ; checkValidType ctxt ty
+        ; return ty }
 
+-----------------
 tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type])
--- Typecheck an instance head.  We can't use 
--- tcHsSigType, because it's not a valid user type.
+-- Like tcHsSigTypeNC, but for an instance head.
 tcHsInstHead ctxt lhs_ty@(L loc hs_ty)
-  = setSrcSpan loc   $ -- No need for an "In the type..." context
-                        -- because that comes from the caller
-    do { kinded_ty <- kc_hs_type hs_ty ekConstraint
-       ; ty <- ds_type kinded_ty
-       ; let (tvs, theta, tau) = tcSplitSigmaTy ty
-       ; case getClassPredTys_maybe tau of
-           Nothing          -> failWithTc (ptext (sLit "Malformed instance type"))
-           Just (clas,tys)  -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys
-                                  ; return (tvs, theta, clas, tys) } }
-
-tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
--- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
--- except that we want to keep the tvs separate
-tcHsQuantifiedType tv_names hs_ty
-  = kcHsTyVars tv_names $ \ tv_names' ->
-    do { kc_ty <- kcHsSigType hs_ty
-       ; tcTyVarBndrs tv_names' $ \ tvs ->
-    do { ty <- dsHsType kc_ty
-       ; return (tvs, ty) } }
-
--- Used for the deriving(...) items
-tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type])
-tcHsDeriv = tc_hs_deriv []
-
-tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name
-            -> TcM ([TyVar], Class, [Type])
-tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty))
-  =    -- Funny newtype deriving form
-       --      forall a. C [a]
-       -- where C has arity 2.  Hence can't use regular functions
-    tc_hs_deriv (tv_names1 ++ tv_names2) ty
-
-tc_hs_deriv tv_names ty
-  | Just (cls_name, hs_tys) <- splitHsClassTy_maybe ty
-  = kcHsTyVars tv_names                 $ \ tv_names' ->
-    do  { cls_kind <- kcClass cls_name
-        ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys
-        ; tcTyVarBndrsKindGen tv_names'        $ \ tyvars ->
-    do  { arg_tys <- dsHsTypes tys
-        ; cls <- tcLookupClass cls_name
-        ; return (tyvars, cls, arg_tys) }}
+  = setSrcSpan loc $    -- The "In the type..." context comes from the caller
+    do { ty <- tcCheckHsTypeAndGen hs_ty constraintKind
+       ; ty <- zonkTcType ty
+       ; checkValidInstance ctxt lhs_ty ty }
 
-  | otherwise
-  = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr ty)
+-----------------
+tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type])
+-- Like tcHsSigTypeNC, but for the ...deriving( ty ) clause
+tcHsDeriv hs_ty 
+  = do { kind <- newMetaKindVar
+       ; ty   <- tcCheckHsTypeAndGen hs_ty kind
+                 -- Funny newtype deriving form
+                 --    forall a. C [a]
+                 -- where C has arity 2. Hence any-kinded result
+       ; ty   <- zonkTcType ty
+       ; let (tvs, pred) = splitForAllTys ty
+       ; case getClassPredTys_maybe pred of
+           Just (cls, tys) -> return (tvs, cls, tys)
+           Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> ppr hs_ty) }
 
 -- Used for 'VECTORISE [SCALAR] instance' declarations
 --
 tcHsVectInst :: LHsType Name -> TcM (Class, [Type])
 tcHsVectInst ty
   | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty
-  = do { cls_kind <- kcClass cls_name
-       ; (tys, _res_kind) <- kcApps cls_name cls_kind tys
-       ; arg_tys <- dsHsTypes tys
-       ; cls <- tcLookupClass cls_name
-       ; return (cls, arg_tys)
-       }
+  = do { (cls, cls_kind) <- tcClass cls_name
+       ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys
+       ; return (cls, arg_tys) }
   | otherwise
   = failWithTc $ ptext (sLit "Malformed instance type")
 \end{code}
@@ -262,365 +226,473 @@ tcHsVectInst ty
        type and class declarations, when we have to
        separate kind-checking, desugaring, and validity checking
 
-\begin{code}
-kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name)
-       -- Used for type signatures
-kcHsSigType ty              = addKcTypeCtxt ty $ kcArgType ty
-kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty
-
-tcHsKindedType :: LHsType Name -> TcM Type
-  -- Don't do kind checking, nor validity checking.
-  -- This is used in type and class decls, where kinding is
-  -- done in advance, and validity checking is done later
-  -- [Validity checking done later because of knot-tying issues.]
-tcHsKindedType hs_ty = dsHsType hs_ty
-
-tcHsBangType :: LHsType Name -> TcM Type
--- Permit a bang, but discard it
--- Input type has already been kind-checked
-tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty
-tcHsBangType ty                    = tcHsKindedType ty
-
-tcHsKindedContext :: LHsContext Name -> TcM ThetaType
--- Used when we are expecting a ClassContext (i.e. no implicit params)
--- Does not do validity checking, like tcHsKindedType
-tcHsKindedContext hs_theta = addLocM (mapM dsHsType) hs_theta
-\end{code}
-
 
 %************************************************************************
 %*                                                                     *
-               The main kind checker: kcHsType
+            The main kind checker: no validity checks here
 %*                                                                     *
 %************************************************************************
        
        First a couple of simple wrappers for kcHsType
 
 \begin{code}
+tcClassSigType :: LHsType Name -> TcM Type
+tcClassSigType lhs_ty@(L _ hs_ty)
+  = addTypeCtxt lhs_ty $
+    do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind
+       ; zonkTcTypeToType emptyZonkEnv ty }
+
+tcHsConArgType :: NewOrData ->  LHsType Name -> TcM Type
+-- Permit a bang, but discard it
+tcHsConArgType NewType  bty = tcHsLiftedType (getBangType bty)
+  -- Newtypes can't have bangs, but we don't check that
+  -- until checkValidDataCon, so do not want to crash here
+
+tcHsConArgType DataType bty = tcHsArgType (getBangType bty)
+  -- Can't allow an unlifted type for newtypes, because we're effectively
+  -- going to remove the constructor while coercing it to a lifted type.
+  -- And newtypes can't be bang'd
+
 ---------------------------
-kcLiftedType :: LHsType Name -> TcM (LHsType Name)
--- The type ty must be a *lifted* *type*
-kcLiftedType ty = kc_lhs_type ty ekLifted
-    
-kcArgs :: SDoc -> [LHsType Name] -> Kind -> TcM [LHsType Name]
-kcArgs what tys kind 
-  = sequence [ kc_lhs_type ty (expArgKind what kind n)
-             | (ty,n) <- tys `zip` [1..] ]
+tcHsArgTys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType]
+tcHsArgTys what tys kinds
+  = sequence [ addTypeCtxt ty $
+               tc_lhs_type ty (expArgKind what kind n)
+             | (ty,kind,n) <- zip3 tys kinds [1..] ]
+
+tc_hs_arg_tys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType]
+-- Just like tcHsArgTys but without the addTypeCtxt
+tc_hs_arg_tys what tys kinds
+  = sequence [ tc_lhs_type ty (expArgKind what kind n)
+             | (ty,kind,n) <- zip3 tys kinds [1..] ]
 
 ---------------------------
-kcArgType :: LHsType Name -> TcM (LHsType Name)
--- The type ty must be an *arg* *type* (lifted or unlifted)
-kcArgType ty = kc_lhs_type ty ekArg
+tcHsArgType, tcHsLiftedType :: LHsType Name -> TcM TcType
+-- Used for type signatures
+-- Do not do validity checking
+tcHsArgType ty           = addTypeCtxt ty $ tc_lhs_type ty ekArg  
+tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted
+
+-- Like tcHsType, but takes an expected kind
+tcCheckLHsType :: LHsType Name -> Kind -> TcM Type
+tcCheckLHsType hs_ty exp_kind
+  = addTypeCtxt hs_ty $ 
+    tc_lhs_type hs_ty (EK exp_kind (ptext (sLit "Expected")))
+
+tcLHsType :: LHsType Name -> TcM (TcType, TcKind)
+-- Called from outside: set the context
+tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty)
 
 ---------------------------
-kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name)
-kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_lhs_type ty kind
+tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type
+-- Input type is HsType, not LhsType; the caller adds the context
+-- Typecheck a type signature, and kind-generalise it
+-- The result is not necessarily zonked, and has not been checked for validity
+tcCheckHsTypeAndGen hs_ty kind
+  = do { ty  <- tc_hs_type hs_ty (EK kind (ptext (sLit "Expected")))
+       ; kvs <- kindGeneralize (tyVarsOfType ty)
+       ; return (mkForAllTys kvs ty) }
 \end{code}
 
-Like tcExpr, kc_hs_type takes an expected kind which it unifies with
+Like tcExpr, tc_hs_type takes an expected kind which it unifies with
 the kind it figures out. When we don't know what kind to expect, we use
-kc_lhs_type_fresh, to first create a new meta kind variable and use that as
+tc_lhs_type_fresh, to first create a new meta kind variable and use that as
 the expected kind.
 
 \begin{code}
-kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind)
--- Called from outside: set the context
-kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type_fresh ty)
-
-kc_lhs_type_fresh :: LHsType Name -> TcM (LHsType Name, TcKind)
-kc_lhs_type_fresh ty =  do
-  kv <- newMetaKindVar
-  r <- kc_lhs_type ty (EK kv (ptext (sLit "Expected")))
-  return (r, kv)
-
-kc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [LHsType Name]
-kc_lhs_types tys_w_kinds = mapM (uncurry kc_lhs_type) tys_w_kinds
-
-kc_lhs_type :: LHsType Name -> ExpKind -> TcM (LHsType Name)
-kc_lhs_type (L span ty) exp_kind
+tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind)
+tc_infer_lhs_type ty =
+  do { kv <- newMetaKindVar
+     ; r <- tc_lhs_type ty (EK kv (ptext (sLit "Expected")))
+     ; return (r, kv) }
+
+tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType
+tc_lhs_type (L span ty) exp_kind
   = setSrcSpan span $
-    do { traceTc "kc_lhs_type" (ppr ty <+> ppr exp_kind)
-       ; ty' <- kc_hs_type ty exp_kind
-       ; return (L span ty') }
-
-kc_hs_type :: HsType Name -> ExpKind -> TcM (HsType Name)
-kc_hs_type (HsParTy ty) exp_kind = do
-   ty' <- kc_lhs_type ty exp_kind
-   return (HsParTy ty')
-
-kc_hs_type (HsTyVar name) exp_kind = do
-   (ty, k) <- kcTyVar name
-   checkExpectedKind ty k exp_kind
-   return ty
-
-kc_hs_type (HsListTy ty) exp_kind = do
-    ty' <- kcLiftedType ty
-    checkExpectedKind ty liftedTypeKind exp_kind
-    return (HsListTy ty')
-
-kc_hs_type (HsPArrTy ty) exp_kind = do
-    ty' <- kcLiftedType ty
-    checkExpectedKind ty liftedTypeKind exp_kind
-    return (HsPArrTy ty')
-
-kc_hs_type (HsKindSig ty sig_k) exp_kind = do
-    sig_k' <- scDsLHsKind sig_k
-    ty' <- kc_lhs_type ty
-             (EK sig_k' (ptext (sLit "An enclosing kind signature specified")))
-    checkExpectedKind ty sig_k' exp_kind
-    return (HsKindSig ty' sig_k)
+    do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind)
+       ; tc_hs_type ty exp_kind }
+
+tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType]
+tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds
+
+------------------------------------------
+tc_hs_type :: HsType Name -> ExpKind -> TcM TcType
+tc_hs_type (HsParTy ty)        exp_kind = tc_lhs_type ty exp_kind
+tc_hs_type (HsDocTy ty _)      exp_kind = tc_lhs_type ty exp_kind
+tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq"      -- Eliminated by renamer
+tc_hs_type (HsBangTy {})       _ = panic "tc_hs_type: bang"   -- Unwrapped by con decls
+tc_hs_type (HsRecTy _)         _ = panic "tc_hs_type: record" -- Unwrapped by con decls
+      -- Record types (which only show up temporarily in constructor 
+      -- signatures) should have been removed by now
+
+---------- Functions and applications
+tc_hs_type hs_ty@(HsTyVar name) exp_kind
+  = do { (ty, k) <- tcTyVar name
+       ; checkExpectedKind hs_ty k exp_kind
+       ; return ty }
+
+tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt)
+  = do { ty1' <- tc_lhs_type ty1 (EK argTypeKind  ctxt)
+       ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt)
+       ; checkExpectedKind ty liftedTypeKind exp_kind
+       ; return (mkFunTy ty1' ty2') }
+
+tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind
+  = do { (op', op_kind) <- tcTyVar op
+       ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind
+       ; return (mkNakedAppTys op' tys') }
+         -- mkNakedAppTys: see Note [Zonking inside the knot]
+
+tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind
+  = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
+       ; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty
+       ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind
+       ; return (mkNakedAppTys fun_ty' arg_tys') }
+         -- mkNakedAppTys: see Note [Zonking inside the knot]
+
+--------- Foralls
+tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind
+  = tcHsTyVarBndrs hs_tvs $ \ tvs' -> 
+    -- Do not kind-generalise here!  See Note [Kind generalisation]
+    do { ctxt' <- tcHsContext context
+       ; ty'   <- tc_lhs_type ty exp_kind
+           -- Why exp_kind?  See Note [Body kind of forall]
+       ; return (mkSigmaTy tvs' ctxt' ty') }
+
+--------- Lists, arrays, and tuples
+tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind 
+  = do { tau_ty <- tc_lhs_type elt_ty ekLifted
+       ; checkExpectedKind hs_ty liftedTypeKind exp_kind
+       ; checkWiredInTyCon listTyCon
+       ; return (mkListTy tau_ty) }
+
+tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind
+  = do { tau_ty <- tc_lhs_type elt_ty ekLifted
+       ; checkExpectedKind hs_ty liftedTypeKind exp_kind
+       ; checkWiredInTyCon parrTyCon
+       ; return (mkPArrTy tau_ty) }
 
 -- See Note [Distinguishing tuple kinds] in HsTypes
-kc_hs_type ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt)
-  | isConstraintOrLiftedKind exp_k -- (NB: not zonking, to avoid left-right bias)
-  = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys exp_k
-       ; return $ if isConstraintKind exp_k
-                    then HsTupleTy HsConstraintTuple tys'
-                    else HsTupleTy HsBoxedTuple      tys' }
+-- See Note [Inferring tuple kinds]
+tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt)
+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
+  | isConstraintKind exp_k = tc_tuple hs_ty HsConstraintTuple tys exp_kind
+  | isLiftedTypeKind exp_k = tc_tuple hs_ty HsBoxedTuple      tys exp_kind
   | otherwise
-  -- It is not clear from the context if it's * or Constraint, 
-  -- so we infer the kind from the arguments
   = do { k <- newMetaKindVar
-       ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k 
+       ; tau_tys <- tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k)
        ; k' <- zonkTcKind k
-       ; if isConstraintKind k'
-         then do { checkExpectedKind ty k' exp_kind
-                 ; return (HsTupleTy HsConstraintTuple tys') }
-         -- If it's not clear from the arguments that it's Constraint, then
-         -- it must be *. Check the arguments again to give good error messages
+       ; if isConstraintKind k' then
+            finish_tuple hs_ty HsConstraintTuple tau_tys exp_kind
+         else if isLiftedTypeKind k' then
+            finish_tuple hs_ty HsBoxedTuple tau_tys exp_kind
+         else
+            tc_tuple hs_ty HsBoxedTuple tys exp_kind }
+         -- It's not clear what the kind is, so assume *, and
+         -- check the arguments again to give good error messages
          -- in eg. `(Maybe, Maybe)`
-         else do { tys'' <- kcArgs (ptext (sLit "a tuple")) tys liftedTypeKind
-                 ; checkExpectedKind ty liftedTypeKind exp_kind
-                 ; return (HsTupleTy HsBoxedTuple tys'') } }
-{-
-Note that we will still fail to infer the correct kind in this case:
 
-  type T a = ((a,a), D a)
-  type family D :: Constraint -> Constraint
+tc_hs_type hs_ty@(HsTupleTy tup_sort tys) exp_kind
+  = tc_tuple hs_ty tup_sort tys exp_kind
+
+--------- Promoted lists and tuples
+tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind
+  = do { tks <- mapM tc_infer_lhs_type tys
+       ; let taus = map fst tks
+       ; kind <- unifyKinds (ptext (sLit "In a promoted list")) tks
+       ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind
+       ; return (foldr (mk_cons kind) (mk_nil kind) taus) }
+  where
+    mk_cons k a b = mkTyConApp (buildPromotedDataCon consDataCon) [k, a, b]
+    mk_nil  k     = mkTyConApp (buildPromotedDataCon nilDataCon) [k]
+
+tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind
+  = do { tks <- mapM tc_infer_lhs_type tys
+       ; let n          = length tys
+             kind_con   = promotedTupleTyCon   BoxedTuple n
+             ty_con     = promotedTupleDataCon BoxedTuple n
+             (taus, ks) = unzip tks
+             tup_k      = mkTyConApp kind_con ks
+       ; checkExpectedKind hs_ty tup_k exp_kind
+       ; return (mkTyConApp ty_con (ks ++ taus)) }
+
+--------- Constraint types
+tc_hs_type ipTy@(HsIParamTy n ty) exp_kind
+  = do { ty' <- tc_lhs_type ty 
+            (EK liftedTypeKind (ptext (sLit "The type argument of the implicit parameter had")))
+       ; checkExpectedKind ipTy constraintKind exp_kind
+       ; return (mkIPPred n ty') }
+
+tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind 
+  = do { (ty1', kind1) <- tc_infer_lhs_type ty1
+       ; (ty2', kind2) <- tc_infer_lhs_type ty2
+       ; checkExpectedKind ty2 kind2
+              (EK kind1 (ptext (sLit "The left argument of the equality predicate had")))
+       ; checkExpectedKind ty constraintKind exp_kind
+       ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) }
+
+--------- Misc
+tc_hs_type (HsKindSig ty sig_k) exp_kind 
+  = do { sig_k' <- tcLHsKind sig_k
+       ; checkExpectedKind ty sig_k' exp_kind
+       ; tc_lhs_type ty
+             (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) }
+
+tc_hs_type (HsCoreTy ty) exp_kind
+  = do { checkExpectedKind ty (typeKind ty) exp_kind
+       ; return ty }
 
-While kind checking T, we do not yet know the kind of D, so we will default the
-kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
--}
 
-kc_hs_type ty@(HsTupleTy tup_sort tys) exp_kind
-  = do { tys' <- kcArgs cxt_doc tys arg_kind
-       ; checkExpectedKind ty out_kind exp_kind
-       ; return (HsTupleTy tup_sort tys') }
+#ifdef GHCI    /* Only if bootstrapped */
+-- This looks highly bogus to me
+tc_hs_type hs_ty@(HsSpliceTy sp fvs _) exp_kind 
+  = do { (ty, kind) <- tcSpliceType sp fvs
+       ; checkExpectedKind hs_ty kind exp_kind
+
+--        ; kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) 
+--                            kind
+--                     -- See Note [Kind of a type splice]
+       ; return ty }
+#else
+tc_hs_type ty@(HsSpliceTy {}) _exp_kind 
+  = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#endif
+
+tc_hs_type (HsWrapTy {}) _exp_kind 
+  = panic "tc_hs_type HsWrapTy"  -- We kind checked something twice
+
+---------------------------
+tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType
+-- Invariant: tup_sort is not HsBoxedOrConstraintTuple
+tc_tuple hs_ty tup_sort tys exp_kind
+  = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind)
+       ; finish_tuple hs_ty tup_sort tau_tys exp_kind }
   where
     arg_kind = case tup_sort of
                  HsBoxedTuple      -> liftedTypeKind
                  HsUnboxedTuple    -> argTypeKind
                  HsConstraintTuple -> constraintKind
-                 _                 -> panic "kc_hs_type arg_kind"
-    out_kind = case tup_sort of
-                 HsUnboxedTuple    -> ubxTupleKind
-                 _                 -> arg_kind
+                 _                 -> panic "tc_hs_type arg_kind"
     cxt_doc = case tup_sort of
                  HsBoxedTuple      -> ptext (sLit "a tuple")
                  HsUnboxedTuple    -> ptext (sLit "an unboxed tuple")
                  HsConstraintTuple -> ptext (sLit "a constraint tuple")
-                 _                 -> panic "kc_hs_type tup_sort"
-
-kc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) = do
-    ty1' <- kc_lhs_type ty1 (EK argTypeKind  ctxt)
-    ty2' <- kc_lhs_type ty2 (EK openTypeKind ctxt)
-    checkExpectedKind ty liftedTypeKind exp_kind
-    return (HsFunTy ty1' ty2')
-
-kc_hs_type ty@(HsOpTy ty1 (_, l_op@(L loc op)) ty2) exp_kind = do
-    (wop, op_kind) <- kcTyVar op
-    [ty1',ty2'] <- kcCheckApps l_op op_kind [ty1,ty2] ty exp_kind
-    let op' = case wop of
-                HsTyVar name -> (WpKiApps [], L loc name)
-                HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name)
-                _ -> panic "kc_hs_type HsOpTy"
-    return (HsOpTy ty1' op' ty2')
-
-kc_hs_type ty@(HsAppTy ty1 ty2) exp_kind = do
-    let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
-    (fun_ty', fun_kind) <- kc_lhs_type_fresh fun_ty
-    arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind
-    return (mkHsAppTys fun_ty' arg_tys')
-
-kc_hs_type ipTy@(HsIParamTy n ty) exp_kind = do
-    ty' <- kc_lhs_type ty 
-             (EK liftedTypeKind 
-               (ptext (sLit "The type argument of the implicit parameter had")))
-    checkExpectedKind ipTy constraintKind exp_kind
-    return (HsIParamTy n ty')
-
-kc_hs_type ty@(HsEqTy ty1 ty2) exp_kind = do
-    (ty1', kind1) <- kc_lhs_type_fresh ty1
-    (ty2', kind2) <- kc_lhs_type_fresh ty2
-    checkExpectedKind ty2 kind2
-      (EK kind1 (ptext (sLit "The left argument of the equality predicate had")))
-    checkExpectedKind ty constraintKind exp_kind
-    return (HsEqTy ty1' ty2')
-
-kc_hs_type (HsCoreTy ty) exp_kind = do
-    checkExpectedKind ty (typeKind ty) exp_kind
-    return (HsCoreTy ty)
-
-kc_hs_type (HsForAllTy exp tv_names context ty) exp_kind
-  = kcHsTyVars tv_names         $ \ tv_names' ->
-    do { ctxt' <- kcHsContext context
-       ; ty'   <- kc_lhs_type ty exp_kind
-            -- The body of a forall is usually a type, but in principle
-            -- there's no reason to prohibit *unlifted* types.
-            -- In fact, GHC can itself construct a function with an
-            -- unboxed tuple inside a for-all (via CPR analyis; see 
-            -- typecheck/should_compile/tc170).
-             --
-             -- Moreover in instance heads we get forall-types with
-             -- kind Constraint.  
-            --
-            -- Really we should check that it's a type of value kind
-             -- {*, Constraint, #}, but I'm not doing that yet
-             -- Example that should be rejected:  
-             --          f :: (forall (a:*->*). a) Int
-       ; return (HsForAllTy exp tv_names' ctxt' ty') }
-
-kc_hs_type (HsBangTy b ty) exp_kind
-  = do { ty' <- kc_lhs_type ty exp_kind
-       ; return (HsBangTy b ty') }
-
-kc_hs_type ty@(HsRecTy _) _exp_kind
-  = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty)
-      -- Record types (which only show up temporarily in constructor signatures) 
-      -- should have been removed by now
-
-#ifdef GHCI    /* Only if bootstrapped */
-kc_hs_type (HsSpliceTy sp fvs _) exp_kind = do
-    (ty, k) <- kcSpliceType sp fvs
-    checkExpectedKind ty k exp_kind
-    return ty
-#else
-kc_hs_type ty@(HsSpliceTy {}) _exp_kind =
-    failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
-#endif
-
-kc_hs_type (HsQuasiQuoteTy {}) _exp_kind =
-    panic "kc_hs_type"  -- Eliminated by renamer
-
--- Remove the doc nodes here, no need to worry about the location since
--- it's the same for a doc node and its child type node
-kc_hs_type (HsDocTy ty _) exp_kind
-  = kc_hs_type (unLoc ty) exp_kind
-
-kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind
-  = do { ty_k_s <- mapM kc_lhs_type_fresh tys
-       ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s
-       ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind
-       ; return (HsExplicitListTy kind (map fst ty_k_s)) }
+                 _                 -> panic "tc_hs_type tup_sort"
 
-kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do
-  ty_k_s <- mapM kc_lhs_type_fresh tys
-  let tycon   = promotedTupleTyCon BoxedTuple (length tys)
-      tupleKi = mkTyConApp tycon (map snd ty_k_s)
-  checkExpectedKind ty tupleKi exp_kind
-  return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s))
-
-kc_hs_type (HsWrapTy {}) _exp_kind =
-    panic "kc_hs_type HsWrapTy"  -- We kind checked something twice
+finish_tuple :: HsType Name -> HsTupleSort -> [TcType] -> ExpKind -> TcM TcType
+finish_tuple hs_ty tup_sort tau_tys exp_kind
+  = do { checkExpectedKind hs_ty res_kind exp_kind
+       ; checkWiredInTyCon tycon
+       ; return (mkTyConApp tycon tau_tys) }
+  where
+    tycon = tupleTyCon con (length tau_tys)
+    con = case tup_sort of
+            HsUnboxedTuple    -> UnboxedTuple
+            HsBoxedTuple      -> BoxedTuple
+            HsConstraintTuple -> ConstraintTuple
+            _                 -> panic "tc_hs_type HsTupleTy"
+
+    res_kind = case tup_sort of
+                 HsUnboxedTuple    -> ubxTupleKind
+                 HsBoxedTuple      -> liftedTypeKind
+                 HsConstraintTuple -> constraintKind
+                 _                 -> panic "tc_hs_type arg_kind"
 
 ---------------------------
-kcApps :: Outputable a
+tcInferApps :: Outputable a
        => a 
        -> TcKind                       -- Function kind
        -> [LHsType Name]               -- Arg types
-       -> TcM ([LHsType Name], TcKind) -- Kind-checked args
-kcApps the_fun fun_kind args
-  = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args
-       ; args' <- kc_lhs_types args_w_kinds
+       -> TcM ([TcType], TcKind)       -- Kind-checked args
+tcInferApps the_fun fun_kind args
+  = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args
+       ; args' <- tc_lhs_types args_w_kinds
        ; return (args', res_kind) }
 
-kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name]
-           -> HsType Name     -- The type being checked (for err messages only)
-           -> ExpKind         -- Expected kind
-           -> TcM ([LHsType Name])
-kcCheckApps the_fun fun_kind args ty exp_kind
-  = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args
-       ; args_w_kinds' <- kc_lhs_types args_w_kinds
-       ; checkExpectedKind ty res_kind exp_kind
-       ; return args_w_kinds' }
-
+tcCheckApps :: Outputable a 
+            => HsType Name     -- The type being checked (for err messages only)
+            -> a               -- The function
+            -> TcKind -> [LHsType Name]   -- Fun kind and arg types
+           -> ExpKind                    -- Expected kind
+           -> TcM [TcType]
+tcCheckApps hs_ty the_fun fun_kind args exp_kind
+  = do { (arg_tys, res_kind) <- tcInferApps the_fun fun_kind args
+       ; checkExpectedKind hs_ty res_kind exp_kind
+       ; return arg_tys }
 
 ---------------------------
-splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
-splitFunKind _       _      fk [] = return ([], fk)
-splitFunKind the_fun arg_no fk (arg:args)
-  = do { mb_fk <- matchExpectedFunKind fk
-       ; case mb_fk of
-            Nothing       -> failWithTc too_many_args 
-            Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args
-                                ; return ((arg
-                                          ,expArgKind (quotes the_fun) ak arg_no)
-                                         :aks ,rk) } }
+splitFunKind :: SDoc -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
+splitFunKind the_fun fun_kind args
+  = go 1 fun_kind args
   where
+    go _      fk [] = return ([], fk)
+    go arg_no fk (arg:args)
+       = do { mb_fk <- matchExpectedFunKind fk
+            ; case mb_fk of
+                 Nothing       -> failWithTc too_many_args 
+                 Just (ak,fk') -> do { (aks, rk) <- go (arg_no+1) fk' args
+                                     ; let exp_kind = expArgKind (quotes the_fun) ak arg_no
+                                     ; return ((arg, exp_kind) : aks, rk) } }
     too_many_args = quotes the_fun <+>
                    ptext (sLit "is applied to too many type arguments")
 
+
 ---------------------------
-kcHsContext :: LHsContext Name -> TcM (LHsContext Name)
-kcHsContext ctxt = wrapLocM (mapM kcHsLPredType) ctxt
+tcHsContext :: LHsContext Name -> TcM [PredType]
+tcHsContext ctxt = mapM tcHsLPredType (unLoc ctxt)
 
-kcHsLPredType :: LHsType Name -> TcM (LHsType Name)
-kcHsLPredType pred = kc_lhs_type pred ekConstraint
+tcHsLPredType :: LHsType Name -> TcM PredType
+tcHsLPredType pred = tc_lhs_type pred ekConstraint
 
 ---------------------------
-kcTyVar :: Name -> TcM (HsType Name, TcKind)
+tcTyVar :: Name -> TcM (TcType, TcKind)
 -- See Note [Type checking recursive type and class declarations]
 -- in TcTyClsDecls
-kcTyVar name         -- Could be a tyvar, a tycon, or a datacon
+tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
   = do { traceTc "lk1" (ppr name)
        ; thing <- tcLookup name
        ; traceTc "lk2" (ppr name <+> ppr thing)
        ; case thing of
-           ATyVar _ tv           -> wrap_mono (tyVarKind tv)
-           AThing kind           -> wrap_poly kind
-           AGlobal (ATyCon tc)   -> wrap_poly (tyConKind tc)
-           AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly
-           _                     -> wrongThingErr "type" thing name }
+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
+
+           AThing kind -> do { tc <- get_loopy_tc name
+                             ; inst_tycon (mkNakedTyConApp tc) kind }
+                             -- mkNakedTyConApp: see Note [Zonking inside the knot]
+
+           AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc)
+
+           AGlobal (ADataCon dc)
+             | isPromotableType ty -> inst_tycon (mkTyConApp tc) (tyConKind tc)
+             | otherwise -> failWithTc (quotes (ppr dc) <+> ptext (sLit "of type")
+                            <+> quotes (ppr ty) <+> ptext (sLit "is not promotable"))
+             where
+               ty = dataConUserType dc
+               tc = buildPromotedDataCon dc
+
+           ANothing -> failWithTc (ptext (sLit "Promoted kind") <+> 
+                              quotes (ppr name) <+>
+                              ptext (sLit "used in a mutually recursive group"))
+
+           _  -> wrongThingErr "type" thing name }
   where
-    wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind)
-                        ; return (HsTyVar name, kind) }
-    wrap_poly kind
-      | null kvs = wrap_mono kind
+    get_loopy_tc name
+      = do { env <- getGblEnv
+           ; case lookupNameEnv (tcg_type_env env) name of
+                Just (ATyCon tc) -> return tc
+                _                -> return (aThingErr "tcTyVar" name) }
+
+    inst_tycon :: ([Type] -> Type) -> Kind -> TcM (Type, Kind)
+    -- Instantiate the polymorphic kind
+    -- Lazy in the TyCon
+    inst_tycon mk_tc_app kind
+      | null kvs 
+      = return (mk_tc_app [], ki_body)
       | otherwise
       = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind)
-           ; kvs' <- mapM (const newMetaKindVar) kvs
-           ; let ki = substKiWith kvs kvs' ki_body
-           ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) }
-      where (kvs, ki_body) = splitForAllTys kind
-
--- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon
-kcDataCon :: DataCon -> TcM TcKind
-kcDataCon dc = do
-  let ty = dataConUserType dc
-  unless (isPromotableType ty) $ promoteErr dc ty
-  let ki = promoteType ty
-  traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki)
-  return ki
-  where
-    promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type")
-      <+> quotes (ppr ty) <+> ptext (sLit "is not promotable"))
-
-kcClass :: Name -> TcM TcKind
-kcClass cls = do       -- Must be a class
-    thing <- tcLookup cls
-    case thing of
-        AThing kind                         -> return kind
-        AGlobal (ATyCon tc)
-          | Just cls <- tyConClass_maybe tc -> return (tyConKind (classTyCon cls))
-        _                                   -> wrongThingErr "class" thing cls
+           ; ks <- mapM (const newMetaKindVar) kvs
+           ; return (mk_tc_app ks, substKiWith kvs ks ki_body) }
+      where 
+        (kvs, ki_body) = splitForAllTys kind
+
+tcClass :: Name -> TcM (Class, TcKind)
+tcClass cls    -- Must be a class
+  = do { thing <- tcLookup cls
+       ; case thing of
+           AThing kind -> return (aThingErr "tcClass" cls, kind)
+           AGlobal (ATyCon tc)
+             | Just cls <- tyConClass_maybe tc 
+             -> return (cls, tyConKind tc)
+           _ -> wrongThingErr "class" thing cls }
+
+
+aThingErr :: String -> Name -> b
+-- The type checker for types is sometimes called simply to
+-- do *kind* checking; and in that case it ignores the type
+-- returned. Which is a good thing since it may not be available yet!
+aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x)
 \end{code}
 
+Note [Zonking inside the knot]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are checking the argument types of a data constructor.  We
+must zonk the types before making the DataCon, because once built we
+can't change it.  So we must traverse the type.
 
-%************************************************************************
-%*                                                                     *
-               Desugaring
-%*                                                                     *
-%************************************************************************
+BUT the parent TyCon is knot-tied, so we can't look at it yet. 
+
+So we must be careful not to use "smart constructors" for types that
+look at the TyCon or Class involved.  Hence the use of mkNakedXXX
+functions.
+
+This is sadly delicate.
+
+Note [Body kind of a forall]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The body of a forall is usually a type, but in principle
+there's no reason to prohibit *unlifted* types.
+In fact, GHC can itself construct a function with an
+unboxed tuple inside a for-all (via CPR analyis; see 
+typecheck/should_compile/tc170).
+
+Moreover in instance heads we get forall-types with
+kind Constraint.  
+
+Moreover if we have a signature
+   f :: Int#
+then we represent it as (HsForAll Implicit [] [] Int#).  And this must
+be legal!  We can't drop the empty forall until *after* typechecking
+the body because of kind polymorphism:
+   Typeable :: forall k. k -> Constraint
+   data Apply f t = Apply (f t)
+   -- Apply :: forall k. (k -> *) -> k -> *
+   instance Typeable Apply where ...
+Then the dfun has type
+   df :: forall k. Typeable ((k->*) -> k -> *) (Apply k)
+
+   f :: Typeable Apply
+
+   f :: forall (t:k->*) (a:k).  t a -> t a
+
+   class C a b where
+      op :: a b -> Typeable Apply
+
+   data T a = MkT (Typeable Apply)
+            | T2 a
+      T :: * -> *
+      MkT :: forall k. (Typeable ((k->*) -> k -> *) (Apply k)) -> T a
+
+   f :: (forall (k:BOX). forall (t:: k->*) (a:k). t a -> t a) -> Int
+   f :: (forall a. a -> Typeable Apply) -> Int
+
+So we *must* keep the HsForAll on the instance type
+   HsForAll Implicit [] [] (Typeable Apply)
+so that we do kind generalisation on it.
+
+Really we should check that it's a type of value kind
+{*, Constraint, #}, but I'm not doing that yet
+Example that should be rejected:  
+         f :: (forall (a:*->*). a) Int
+
+Note [Inferring tuple kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,
+we try to figure out whether it's a tuple of kind * or Constraint.
+  Step 1: look at the expected kind
+  Step 2: infer argument kinds
+
+If after Step 2 it's not clear from the arguments that it's
+Constraint, then it must be *.  Once having decided that we re-check
+the Check the arguments again to give good error messages
+in eg. `(Maybe, Maybe)`
+
+Note that we will still fail to infer the correct kind in this case:
+
+  type T a = ((a,a), D a)
+  type family D :: Constraint -> Constraint
+
+While kind checking T, we do not yet know the kind of D, so we will default the
+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
 
 Note [Desugaring types]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -654,116 +726,6 @@ Moreover
        (a) spurious ! annotations.
        (b) a class used as a type
 
-\begin{code}
-
-zonkTcKindToKind :: TcKind -> TcM Kind
--- When zonking a TcKind to a kind we instantiate kind variables to AnyK
-zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy)
-
-dsHsType :: LHsType Name -> TcM Type
--- All HsTyVarBndrs in the intput type are kind-annotated
--- See Note [Desugaring types]
-dsHsType ty = ds_type (unLoc ty)
-
-ds_type :: HsType Name -> TcM Type
--- See Note [Desugaring types]
-ds_type ty@(HsTyVar _)
-  = ds_app ty []
-
-ds_type (HsParTy ty)           -- Remove the parentheses markers
-  = dsHsType ty
-
-ds_type ty@(HsBangTy {})    -- No bangs should be here
-  = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
-
-ds_type ty@(HsRecTy {})            -- No bangs should be here
-  = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty)
-
-ds_type (HsKindSig ty _)
-  = dsHsType ty        -- Kind checking done already
-
-ds_type (HsListTy ty) = do
-    tau_ty <- dsHsType ty
-    checkWiredInTyCon listTyCon
-    return (mkListTy tau_ty)
-
-ds_type (HsPArrTy ty) = do
-    tau_ty <- dsHsType ty
-    checkWiredInTyCon parrTyCon
-    return (mkPArrTy tau_ty)
-
-ds_type (HsTupleTy hs_con tys) = do
-    con <- case hs_con of
-        HsUnboxedTuple    -> return UnboxedTuple
-        HsBoxedTuple      -> return BoxedTuple
-        HsConstraintTuple -> return ConstraintTuple
-        _ -> panic "ds_type HsTupleTy"
-        -- failWithTc (ptext (sLit "Unexpected tuple component kind:") <+> ppr kind')
-    let tycon = tupleTyCon con (length tys)
-    tau_tys <- dsHsTypes tys
-    checkWiredInTyCon tycon
-    return (mkTyConApp tycon tau_tys)
-
-ds_type (HsFunTy ty1 ty2) = do
-    tau_ty1 <- dsHsType ty1
-    tau_ty2 <- dsHsType ty2
-    return (mkFunTy tau_ty1 tau_ty2)
-
-ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) =
-    setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2])
-
-ds_type ty@(HsAppTy _ _)
-  = ds_app ty []
-
-ds_type (HsIParamTy n ty) = do
-    tau_ty <- dsHsType ty
-    return (mkIPPred n tau_ty)
-
-ds_type (HsEqTy ty1 ty2) = do
-    tau_ty1 <- dsHsType ty1
-    tau_ty2 <- dsHsType ty2
-    return (mkEqPred (tau_ty1, tau_ty2))
-
-ds_type (HsForAllTy _ tv_names ctxt ty)
-  = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do
-    theta <- mapM dsHsType (unLoc ctxt)
-    tau <- dsHsType ty
-    return (mkSigmaTy tyvars theta tau)
-
-ds_type (HsDocTy ty _)  -- Remove the doc comment
-  = dsHsType ty
-
-ds_type (HsSpliceTy _ _ kind) 
-  = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) 
-                           kind
-                     -- See Note [Kind of a type splice]
-       ; newFlexiTyVarTy kind' }
-
-ds_type (HsQuasiQuoteTy {}) = panic "ds_type"  -- Eliminated by renamer
-ds_type (HsCoreTy ty)       = return ty
-
-ds_type (HsExplicitListTy kind tys) = do
-  kind' <- zonkTcKindToKind kind
-  ds_tys <- mapM dsHsType tys
-  return $
-   foldr (\a b -> mkTyConApp (buildPromotedDataCon consDataCon) [kind', a, b])
-         (mkTyConApp (buildPromotedDataCon nilDataCon) [kind']) ds_tys
-
-ds_type (HsExplicitTupleTy kis tys) = do
-  MASSERT( length kis == length tys )
-  kis' <- mapM zonkTcKindToKind kis
-  tys' <- mapM dsHsType tys
-  return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys')
-
-ds_type (HsWrapTy (WpKiApps kappas) ty) = do
-  tau <- ds_type ty
-  kappas' <- mapM zonkTcKindToKind kappas
-  return (mkAppTys tau kappas')
-
-dsHsTypes :: [LHsType Name] -> TcM [Type]
-dsHsTypes arg_tys = mapM dsHsType arg_tys
-\end{code}
-
 Note [Kind of a type splice]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider these terms, each with TH type splice inside:
@@ -783,41 +745,13 @@ Help functions for type applications
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-ds_app :: HsType Name -> [LHsType Name] -> TcM Type
-ds_app (HsAppTy ty1 ty2) tys
-  = ds_app (unLoc ty1) (ty2:tys)
-
-ds_app ty tys = do
-    arg_tys <- dsHsTypes tys
-    case ty of
-       HsTyVar fun -> ds_var_app fun arg_tys
-       _           -> do fun_ty <- ds_type ty
-                          return (mkAppTys fun_ty arg_tys)
-
-ds_var_app :: Name -> [Type] -> TcM Type
--- See Note [Type checking recursive type and class declarations]
--- in TcTyClsDecls
-ds_var_app name arg_tys 
-  | isTvNameSpace (rdrNameSpace (nameRdrName name))
-  = do { thing <- tcLookup name
-       ; case thing of
-           ATyVar _ tv -> return (mkAppTys (mkTyVarTy tv) arg_tys)
-          _           -> wrongThingErr "type" thing name }
-
-  | otherwise
-  = do { thing <- tcLookupGlobal name
-       ; case thing of
-           ATyCon tc   -> return (mkTyConApp tc arg_tys)
-           ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) 
-          _           -> wrongThingErr "type" (AGlobal thing) name }
-
-addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
+addTypeCtxt :: LHsType Name -> TcM a -> TcM a
        -- Wrap a context around only if we want to show that contexts.  
        -- Omit invisble ones and ones user's won't grok
-addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing
-
-typeCtxt :: HsType Name -> SDoc
-typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty)
+addTypeCtxt (L _ ty) thing 
+  = addErrCtxt doc thing
+  where
+    doc = ptext (sLit "In the type") <+> quotes (ppr ty)
 \end{code}
 
 %************************************************************************
@@ -842,16 +776,30 @@ then we'd also need
                           since we only have BOX for a super kind)
 
 \begin{code}
-kcHsTyVars :: [LHsTyVarBndr Name] 
-          -> ([LHsTyVarBndr Name] -> TcM r)    -- These binders are kind-annotated
-                                               -- They scope over the thing inside
-          -> TcM r
-kcHsTyVars tvs thing_inside
-  = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs
-       ; tcExtendKindEnvTvs kinded_tvs thing_inside }
-
-kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
--- Return a *kind-annotated* binder, whose PostTcKind is
+bindScopedKindVars :: [LHsTyVarBndr Name] -> TcM a -> TcM a
+-- Given some tyvar binders like [a (b :: k -> *) (c :: k)]
+-- bind each scoped kind variable (k in this case) to a fresh
+-- kind skolem variable
+bindScopedKindVars hs_tvs thing_inside
+  = tcExtendTyVarEnv kvs thing_inside
+  where
+    kvs :: [KindVar]   -- All skolems
+    kvs = [ mkKindSigVar kv 
+          | L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs
+          , kv <- kvs ]
+
+tcHsTyVarBndrs :: [LHsTyVarBndr Name] 
+              -> ([TyVar] -> TcM r)
+              -> TcM r
+-- Bind the type variables to skolems, each with a meta-kind variable kind
+tcHsTyVarBndrs hs_tvs thing_inside
+  = bindScopedKindVars hs_tvs $
+    do { tvs <- mapM tcHsTyVarBndr hs_tvs
+       ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs)
+       ; tcExtendTyVarEnv tvs (thing_inside tvs) }
+
+tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TyVar
+-- Return a type variable 
 -- initialised with a kind variable.
 -- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind 
 -- in it. We aren't yet sure whether the binder is a *type* variable or a *kind*
@@ -862,48 +810,99 @@ kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
 --   instance C (a,b) where
 --     type F (a,b) c = ...
 -- Here a,b will be in scope when processing the associated type instance for F.
-kcHsTyVar tyvar = do in_scope <- getInLocalScope
-                     if in_scope (hsTyVarName tyvar)
-                      then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar)
-                              return (UserTyVar (tyVarName inscope_tyvar)
-                                (tyVarKind inscope_tyvar)) 
-                       else kcHsTyVar' tyvar
-    where
-        kcHsTyVar' (UserTyVar name _)        = UserTyVar name <$> newMetaKindVar
-        kcHsTyVar' (KindedTyVar name kind _) = do
-          kind' <- scDsLHsKind kind
-          return (KindedTyVar name kind kind')
+tcHsTyVarBndr (L _ hs_tv)
+  = do { let name = hsTyVarName hs_tv
+       ; mb_tv <- tcLookupLcl_maybe name
+       ; case mb_tv of {
+           Just (ATyVar _ tv) -> return tv ;
+           _ -> do
+       { kind <- case hs_tv of
+                   UserTyVar {} -> newMetaKindVar
+                   KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind
+       ; return (mkTyVar name kind) } } }
 
 ------------------
-tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking
-             -> ([TyVar] -> TcM r)
-             -> TcM r
--- Used when type-checking types/classes/type-decls
--- Brings into scope immutable TyVars, not mutable ones that require later zonking
--- Fix #5426: avoid abstraction over kinds containing # or (#)
-tcTyVarBndrs bndrs thing_inside = do
-    tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs
-    tcExtendTyVarEnv tyvars (thing_inside tyvars)
-  where
-    zonk (name, kind)
-      = do { kind' <- zonkTcKind kind
-           ; return (mkTyVar name kind') }
-
-tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r
--- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside
--- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)]
-tcTyVarBndrsKindGen bndrs thing_inside
-  = do { let kinds = map (hsTyVarKind . unLoc) bndrs
-       ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds
-       ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds
-             ktvs = kvs ++ tyvars     -- See Note [Kinds of quantified type variables]
-       ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars))
-       ; tcExtendTyVarEnv ktvs (thing_inside ktvs) }
+tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] 
+                 -> TcM r 
+                 -> TcM ([TyVar], r)
+-- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside
+-- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)]
+tcHsTyVarBndrsGen hs_tvs thing_inside
+  = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) 
+       ; (tvs, res) <- tcHsTyVarBndrs hs_tvs $ \ tvs ->
+                       do { res <- thing_inside
+                          ; return (tvs, res) }
+       ; let kinds = map tyVarKind tvs
+       ; (kvs', zonked_kinds) <- kindGeneralizeKinds kinds
+       ; let tvs' = zipWith setTyVarKind tvs zonked_kinds
+                     -- See Note [Kinds of quantified type variables]
+       ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs))
+       ; return (kvs' ++ tvs', res) }
+
+------------------
+-- Used when generalizing binders and type family patterns
+-- It takes a kind from the type checker (like `k0 -> *`), and returns the 
+-- final, kind-generalized kind (`forall k::BOX. k -> *`)
+kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind])
+-- INVARIANT: the returned kinds are zonked, and
+--            mention the returned kind variables
+kindGeneralizeKinds kinds 
+  = do { -- Quantify over kind variables free in
+         -- the kinds, and *not* in the environment
+       ; traceTc "kindGeneralizeKinds 1" (ppr kinds)
+
+       ; kvs <- kindGeneralize (tyVarsOfTypes kinds)
+
+         -- Zonk the kinds again, to pick up either the kind 
+         -- variables we quantify over, or *, depending on whether
+         -- zonkQuantifiedTyVars decided to generalise (which in
+         -- turn depends on PolyKinds)
+       ; final_kinds <- mapM zonkTcKind kinds
+
+       ; traceTc "kindGeneralizeKinds 2" (vcat [ ppr kinds, ppr kvs, ppr final_kinds ])
+       ; return (kvs, final_kinds) }
+
+
+kindGeneralizeKind :: TcKind -> TcM ([KindVar], Kind)    
+-- Unary version of kindGeneralizeKinds
+kindGeneralizeKind kind
+  = do { kvs   <- kindGeneralize (tyVarsOfType kind)
+       ; kind' <- zonkTcKind kind
+       ; return (kvs, kind') }
+
+kindGeneralize :: TyVarSet -> TcM [KindVar]
+kindGeneralize tkvs
+  = do { gbl_tvs  <- tcGetGlobalTyVars -- Already zonked
+       ; tidy_env <- tcInitTidyEnv
+       ; tkvs     <- zonkTyVarsAndFV tkvs
+       ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs)
+
+             (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify
+                           -- We do not get a later chance to tidy!
+
+       ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs)
+         zonkQuantifiedTyVars tidy_kvs_to_quantify }
 \end{code}
 
+Note [Kind generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do kind generalisation only at the outer level of a type signature.
+For example, consider
+  T :: forall k. k -> *
+  f :: (forall a. T a -> Int) -> Int
+When kind-checking f's type signature we generalise the kind at
+the outermost level, thus:
+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!
+and *not* at the inner forall:
+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!
+Reason: same as for HM inference on value level declarations,
+we want to infer the most general type.  The f2 type signature
+would be *less applicable* than f1, becuase it requires a more
+polymorphic argument.
+
 Note [Kinds of quantified type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcTyVarBndrsKindGen quantifies over a specified list of type variables,
+tcTyVarBndrsGen quantifies over a specified list of type variables,
 *and* over the kind variables mentioned in the kinds of those tyvars.
 
 Note that we must zonk those kinds (obviously) but less obviously, we
@@ -918,24 +917,75 @@ Reason: we're going to turn this into a for-all type,
 which the type checker will then instantiate, and instantiate does not
 look through unification variables!  
 
-Hence using zonked_kinds when forming 'tyvars'.
+Hence using zonked_kinds when forming tvs'.
 
 \begin{code}
+--------------------
+-- getInitialKind has made a suitably-shaped kind for the type or class
+-- Unpack it, and attribute those kinds to the type variables
+-- Extend the env with bindings for the tyvars, taken from
+-- the kind of the tycon/class.  Give it to the thing inside, and 
+-- check the result kind matches
+kcLookupKind :: Name -> TcM Kind
+kcLookupKind nm 
+  = do { tc_ty_thing <- tcLookup nm
+       ; case tc_ty_thing of
+           AThing k            -> return k
+           AGlobal (ATyCon tc) -> return (tyConKind tc)
+           _                   -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
+
+kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a
+-- Used for the type varaibles of a type or class decl,
+-- when doing the initial kind-check.  
+kcTyClTyVars name hs_tvs thing_inside
+  = bindScopedKindVars hs_tvs $
+    do         { tc_kind <- kcLookupKind name
+       ; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind
+                     -- There should be enough arrows, because
+                     -- getInitialKinds used the tcdTyVars
+        ; name_ks <- zipWithM kc_tv hs_tvs arg_ks
+        ; tcExtendKindEnv name_ks (thing_inside res_k) }
+  where
+    kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
+    kc_tv (L _ (UserTyVar n _)) exp_k 
+      = do { check_in_scope n exp_k
+           ; return (n, exp_k) }
+    kc_tv (L _ (KindedTyVar n (HsBSig hs_k _) _)) exp_k
+      = do { k <- tcLHsKind hs_k
+           ; _ <- unifyKind k exp_k
+           ; check_in_scope n exp_k
+           ; return (n, k) }
+
+    check_in_scope :: Name -> Kind -> TcM ()
+    -- In an associated type decl, the type variable may already 
+    -- be in scope; in that case we want to make sure it matches
+    -- any signature etc here
+    check_in_scope n exp_k
+      = do { mb_thing <- tcLookupLcl_maybe n
+           ; case mb_thing of
+               Nothing         -> return ()
+               Just (AThing k) -> discardResult (unifyKind k exp_k)
+               Just thing      -> pprPanic "check_in_scope" (ppr thing) }
+
+-----------------------
 tcTyClTyVars :: Name -> [LHsTyVarBndr Name]    -- LHS of the type or class decl
              -> ([TyVar] -> Kind -> TcM a) -> TcM a
+-- Used for the type variables of a type or class decl,
+-- on the second pass when constructing the final result
 -- (tcTyClTyVars T [a,b] thing_inside) 
 --   where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
 --   calls thing_inside with arguments
---      [k1,k2,a,b] (k2 -> *)  
+--      [k1,k2,a,b] (k2 -> *)
+--   having also extended the type environment with bindings 
+--   for k1,k2,a,b
 --
 -- No need to freshen the k's because they are just skolem 
 -- constants here, and we are at top level anyway.
 tcTyClTyVars tycon tyvars thing_inside
   = do { thing <- tcLookup tycon
-       ; let { kind =
-                 case thing of
-                   AThing kind -> kind
-                   _ -> panic "tcTyClTyVars"
+       ; let { kind = case thing of
+                        AThing kind -> kind
+                        _ -> panic "tcTyClTyVars"
                      -- We only call tcTyClTyVars during typechecking in
                      -- TcTyClDecls, where the local env is extended with
                      -- the generalized_env (mapping Names to AThings).
@@ -946,43 +996,6 @@ tcTyClTyVars tycon tyvars thing_inside
              ; all_vs = kvs ++ tvs }
        ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) }
 
--- Used when generalizing binders and type family patterns
--- It takes a kind from the type checker (like `k0 -> *`), and returns the 
--- final, kind-generalized kind (`forall k::BOX. k -> *`)
-kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind])
--- INVARIANT: the returned kinds are zonked, and
---            mention the returned kind variables
-kindGeneralizeKinds kinds 
-  = do { -- Quantify over kind variables free in
-         -- the kinds, and *not* in the environment
-       ; traceTc "kindGeneralizeKinds 1" (ppr kinds)
-       ; zonked_kinds <- mapM zonkTcKind kinds
-       ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked
-       ; tidy_env <- tcInitTidyEnv
-       ; let kvs_to_quantify = varSetElems (tyVarsOfTypes zonked_kinds
-                                            `minusVarSet` gbl_tvs)
-
-             (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify
-                           -- We do not get a later chance to tidy!
-
-       ; kvs <- ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify)
-                zonkQuantifiedTyVars tidy_kvs_to_quantify
-
-         -- Zonk the kinds again, to pick up either the kind 
-         -- variables we quantify over, or *, depending on whether
-         -- zonkQuantifiedTyVars decided to generalise (which in
-         -- turn depends on PolyKinds)
-       ; final_kinds <- mapM zonkTcKind zonked_kinds
-
-       ; traceTc "kindGeneralizeKinds 2" (vcat [ ppr gbl_tvs, ppr kinds, ppr kvs_to_quantify
-                                        , ppr kvs, ppr final_kinds ])
-       ; return (kvs, final_kinds) }
-
-kindGeneralizeKind :: TcKind -> TcM ( [KindVar]  -- these were flexi kind vars
-                                    , Kind )     -- this is the old kind where flexis got zonked
-kindGeneralizeKind kind = do
-  (kvs, [kind']) <- kindGeneralizeKinds [kind]
-  return (kvs, kind')
 
 -----------------------------------
 tcDataKindSig :: Kind -> TcM [TyVar]
@@ -1076,32 +1089,27 @@ Historical note:
 
 \begin{code}
 tcHsPatSigType :: UserTypeCtxt
-              -> LHsType Name          -- The type signature
-              -> TcM ([TyVar],         -- Newly in-scope type variables
-                       Type)           -- The signature
+              -> HsBndrSig (LHsType Name)  -- The type signature
+              -> TcM ([TyVar],             -- Newly in-scope type variables
+                       Type)               -- The signature
 -- Used for type-checking type signatures in
 -- (a) patterns          e.g  f (x::Int) = e
 -- (b) result signatures  e.g. g x :: Int = e
 -- (c) RULE forall bndrs  e.g. forall (x::Int). f x = x
 
-tcHsPatSigType ctxt hs_ty 
+tcHsPatSigType ctxt (HsBSig hs_ty sig_tvs)
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
-    do {       -- Find the type variables that are mentioned in the type
-               -- but not already in scope.  These are the ones that
-               -- should be bound by the pattern signature
-         in_scope <- getInLocalScope
-       ; let span = getLoc hs_ty
-             sig_tvs = userHsTyVarBndrs $ map (L span) $ 
-                       filterOut in_scope $
-                        nameSetToList (extractHsTyVars hs_ty)
-
-       ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
+    do { let new_tv name = do { kind <- newMetaKindVar
+                               ; return (mkTyVar name kind) }
+        ; tvs <- mapM new_tv sig_tvs
+       ; sig_ty <- tcExtendTyVarEnv tvs $
+                    tcHsLiftedType hs_ty
+        ; sig_ty <- zonkTcType sig_ty
        ; checkValidType ctxt sig_ty 
-       ; return (tyvars, sig_ty)
-      }
+       ; return (tvs, sig_ty) }
 
 tcPatSig :: UserTypeCtxt
-        -> LHsType Name
+        -> HsBndrSig (LHsType Name)
         -> TcSigmaType
         -> TcM (TcType,            -- The type to use for "inside" the signature
                 [(Name, TcTyVar)], -- The new bit of type environment, binding
@@ -1118,17 +1126,16 @@ tcPatSig ctxt sig res_ty
                -- Just do the subsumption check and return
                   wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty
                ; return (sig_ty, [], wrap)
-        } else do {
+        } else do
                -- Type signature binds at least one scoped type variable
        
                -- A pattern binding cannot bind scoped type variables
-               -- The renamer fails with a name-out-of-scope error 
-               -- if a pattern binding tries to bind a type variable,
-               -- So we just have an ASSERT here
-       ; let in_pat_bind = case ctxt of
+                -- It is more convenient to make the test here
+                -- than in the renamer
+       { let in_pat_bind = case ctxt of
                                BindPatSigCtxt -> True
                                _              -> False
-       ; ASSERT( not in_pat_bind || null sig_tvs ) return ()
+       ; when in_pat_bind (addErr (patBindSigErr sig_tvs))
 
                -- Check that all newly-in-scope tyvars are in fact
                -- constrained by the pattern.  This catches tiresome
@@ -1141,8 +1148,8 @@ tcPatSig ctxt sig res_ty
        ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
 
        -- Now do a subsumption check of the pattern signature against res_ty
-        ; sig_tvs' <- tcInstSigTyVars sig_tvs
-        ; let sig_ty' = substTyWith sig_tvs (mkTyVarTys sig_tvs') sig_ty
+        ; (subst, sig_tvs') <- tcInstSigTyVars sig_tvs
+        ; let sig_ty' = substTy subst sig_ty
        ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
 
        -- Check that each is bound to a distinct type variable,
@@ -1168,6 +1175,12 @@ tcPatSig ctxt sig res_ty
                -- as some other in-scope type variable
        where
          dups = [n' | (n',tv') <- in_scope, tv' == tv]
+
+patBindSigErr :: [TyVar] -> SDoc
+patBindSigErr sig_tvs 
+  = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs
+          <+> pprQuotedList sig_tvs)
+       2 (ptext (sLit "in a pattern binding signature"))
 \end{code}
 
 
@@ -1203,13 +1216,13 @@ expArgKind exp kind arg_no = EK kind (ptext (sLit "The") <+> speakNth arg_no
                                   <+> ptext (sLit "argument of") <+> exp
                                   <+> ptext (sLit "should have"))
 
-unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind
-unifyKinds fun act_kinds = do
-  kind <- newMetaKindVar
-  let checkArgs (arg_no, (ty, act_kind)) = 
-        checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no)
-  mapM_ checkArgs (zip [1..] act_kinds)
-  return kind
+unifyKinds :: SDoc -> [(TcType, TcKind)] -> TcM TcKind
+unifyKinds fun act_kinds
+  = do { kind <- newMetaKindVar
+       ; let check (arg_no, (ty, act_kind)) 
+               = checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no)
+       ; mapM_ check (zip [1..] act_kinds)
+       ; return kind }
 
 checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM ()
 -- A fancy wrapper for 'unifyKind', which tries
@@ -1279,65 +1292,59 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do
 %*                                                                      *
 %************************************************************************
 
-scDsLHsKind converts a user-written kind to an internal, sort-checked kind.
+tcLHsKind converts a user-written kind to an internal, sort-checked kind.
 It does sort checking and desugaring at the same time, in one single pass.
 It fails when the kinds are not well-formed (eg. data A :: * Int), or if there
 are non-promotable or non-fully applied kinds.
 
 \begin{code}
-scDsLHsKind :: LHsKind Name -> TcM Kind
-scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $
-                  sc_ds_lhs_kind k
+tcLHsKind :: LHsKind Name -> TcM Kind
+tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $
+              tc_lhs_kind k
 
-scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind)
-scDsLHsMaybeKind Nothing  = return Nothing
-scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k
-                               return (Just k')
-
-sc_ds_lhs_kind :: LHsKind Name -> TcM Kind
-sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki)
+tc_lhs_kind :: LHsKind Name -> TcM Kind
+tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki)
 
 -- The main worker
-sc_ds_hs_kind :: HsKind Name -> TcM Kind
-sc_ds_hs_kind k@(HsTyVar _)   = sc_ds_app k []
-sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k []
+tc_hs_kind :: HsKind Name -> TcM Kind
+tc_hs_kind k@(HsTyVar _)   = tc_app k []
+tc_hs_kind k@(HsAppTy _ _) = tc_app k []
 
-sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki
+tc_hs_kind (HsParTy ki) = tc_lhs_kind ki
 
-sc_ds_hs_kind (HsFunTy ki1 ki2) =
-  do kappa_ki1 <- sc_ds_lhs_kind ki1
-     kappa_ki2 <- sc_ds_lhs_kind ki2
+tc_hs_kind (HsFunTy ki1 ki2) =
+  do kappa_ki1 <- tc_lhs_kind ki1
+     kappa_ki2 <- tc_lhs_kind ki2
      return (mkArrowKind kappa_ki1 kappa_ki2)
 
-sc_ds_hs_kind (HsListTy ki) =
-  do kappa <- sc_ds_lhs_kind ki
+tc_hs_kind (HsListTy ki) =
+  do kappa <- tc_lhs_kind ki
      checkWiredInTyCon listTyCon
      return $ mkPromotedListTy kappa
 
-sc_ds_hs_kind (HsTupleTy _ kis) =
-  do kappas <- mapM sc_ds_lhs_kind kis
+tc_hs_kind (HsTupleTy _ kis) =
+  do kappas <- mapM tc_lhs_kind kis
      checkWiredInTyCon tycon
      return $ mkTyConApp tycon kappas
   where 
      tycon = promotedTupleTyCon BoxedTuple (length kis)
 
 -- Argument not kind-shaped
-sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k)
+tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k)
 
 -- Special case for kind application
-sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
-sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis)
-sc_ds_app (HsTyVar tc)      kis =
-  do arg_kis <- mapM sc_ds_lhs_kind kis
-     sc_ds_var_app tc arg_kis
-sc_ds_app ki                _   = failWithTc (quotes (ppr ki) <+> 
+tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
+tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis)
+tc_app (HsTyVar tc)      kis =
+  do arg_kis <- mapM tc_lhs_kind kis
+     tc_var_app tc arg_kis
+tc_app ki                _   = failWithTc (quotes (ppr ki) <+> 
                                     ptext (sLit "is not a kind constructor"))
 
--- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar
-sc_ds_var_app :: Name -> [Kind] -> TcM Kind
+tc_var_app :: Name -> [Kind] -> TcM Kind
 -- Special case for * and Constraint kinds
 -- They are kinds already, so we don't need to promote them
-sc_ds_var_app name arg_kis
+tc_var_app name arg_kis
   |  name == liftedTypeKindTyConName
   || name == constraintKindTyConName
   = do { unless (null arg_kis)
@@ -1345,10 +1352,10 @@ sc_ds_var_app name arg_kis
        ; thing <- tcLookup name
        ; case thing of
            AGlobal (ATyCon tc) -> return (mkTyConApp tc [])
-           _                   -> panic "sc_ds_var_app 1" }
+           _                   -> panic "tc_var_app 1" }
 
 -- General case
-sc_ds_var_app name arg_kis = do
+tc_var_app name arg_kis = do
   (_errs, mb_thing) <- tryTc (tcLookup name)
   case mb_thing of
     Just (AGlobal (ATyCon tc))
@@ -1361,11 +1368,16 @@ sc_ds_var_app name arg_kis = do
         Just _  -> err tc "is not fully applied"
         Nothing -> err tc "is not promotable"
 
+    -- A lexically scoped kind variable
+    Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
+
     -- It is in scope, but not what we expected
     Just thing -> wrongThingErr "promoted type" thing name
 
     -- It is not in scope, but it passed the renamer: staging error
-    Nothing    -> ASSERT2 ( isTyConName name, ppr name )
+    Nothing    -> -- ASSERT2 ( isTyConName name, ppr name )
+              do  env <- getLclEnv
+                  traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env))
                   failWithTc (ptext (sLit "Promoted kind") <+> 
                               quotes (ppr name) <+>
                               ptext (sLit "used in a mutually recursive group"))
index 69d7295..229fed3 100644 (file)
@@ -392,6 +392,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                         -- try the deriving stuff, because that may give
                         -- more errors still
 
+       ; traceTc "tcDeriving" empty
        ; (gbl_env, deriv_inst_info, deriv_binds)
               <- tcDeriving tycl_decls inst_decls deriv_decls
 
@@ -426,7 +427,8 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a
 addFamInsts fam_insts thing_inside
   = tcExtendLocalFamInstEnv fam_insts $ 
     tcExtendGlobalEnvImplicit things  $ 
-    do { tcg_env <- tcAddImplicits things
+    do { traceTc "addFamInsts" (pprFamInsts fam_insts)
+       ; tcg_env <- tcAddImplicits things
        ; setGblEnv tcg_env thing_inside }
   where
     axioms = map famInstAxiom fam_insts
@@ -567,8 +569,8 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
          -- Kind check type patterns
-       ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ 
-           \tvs' pats' resultKind -> do
+       ; tcFamTyPats fam_tc tvs pats (kcDataDecl decl) $ 
+           \tvs' pats' res_kind -> do
 
          -- Check that left-hand side contains no type family applications
          -- (vanilla synonyms are fine, though, and we checked for
@@ -576,9 +578,9 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
        { mapM_ checkTyFamFreeness pats'
          
          -- Result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc)
+       ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
 
-       ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt
+       ; stupid_theta <- tcHsContext ctxt
        ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons
 
          -- Construct representation tycon
@@ -794,34 +796,59 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    loc       = getSrcSpan dfun_id
 
 ------------------------------
-checkInstSig :: Class -> [TcType] -> LSig Name -> TcM ()
--- Check that any type signatures have exactly the right type
-checkInstSig clas inst_tys (L loc (TypeSig names@(L _ name1:_) hs_ty))
-  = setSrcSpan loc $ 
-    do { inst_sigs <- xoptM Opt_InstanceSigs
-       ; if inst_sigs then 
-           do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty
-              ; mapM_ (check sigma_ty) names }
-         else
-           addErrTc (misplacedInstSig names hs_ty) }
+----------------------
+mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] 
+          -> [TcType] -> Id -> TcM (TcId, TcSigInfo)
+mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
+  = do  { uniq <- newUnique
+        ; loc <- getSrcSpanM
+        ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
+        ; local_meth_name <- newLocalName sel_name
+                  -- Base the local_meth_name on the selector name, becuase
+                  -- type errors from tcInstanceMethodBody come from here
+
+        ; local_meth_sig <- case lookupHsSig sig_fn sel_name of
+            Just hs_ty  -- There is a signature in the instance declaration
+               -> do { sig_ty <- check_inst_sig hs_ty
+                     ; instTcTySig hs_ty sig_ty local_meth_name }
+
+            Nothing     -- No type signature
+               -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty)
+              -- Absent a type sig, there are no new scoped type variables here
+              -- Only the ones from the instance decl itself, which are already
+              -- in scope.  Example:
+              --      class C a where { op :: forall b. Eq b => ... }
+              --      instance C [c] where { op = <rhs> }
+              -- In <rhs>, 'c' is scope but 'b' is not!
+
+        ; let meth_id = mkLocalId meth_name meth_ty
+        ; return (meth_id, local_meth_sig) }
   where
-    check sigma_ty (L _ n) 
-      = do { sel_id <- tcLookupId n
-           ; let meth_ty = instantiateMethod clas sel_id inst_tys
-           ; checkTc (sigma_ty `eqType` meth_ty)
-                     (badInstSigErr n meth_ty) }
-checkInstSig _ _ _ = return ()
+    sel_name      = idName sel_id
+    local_meth_ty = instantiateMethod clas sel_id inst_tys
+    meth_ty       = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
+
+    -- Check that any type signatures have exactly the right type
+    check_inst_sig hs_ty@(L loc _) 
+       = setSrcSpan loc $ 
+         do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty
+            ; inst_sigs <- xoptM Opt_InstanceSigs
+            ; if inst_sigs then 
+                checkTc (sig_ty `eqType` local_meth_ty)
+                        (badInstSigErr sel_name sig_ty) 
+              else
+                addErrTc (misplacedInstSig sel_name hs_ty)
+            ; return sig_ty }
 
 badInstSigErr :: Name -> Type -> SDoc
 badInstSigErr meth ty
   = hang (ptext (sLit "Method signature does not match class; it should be"))
        2 (pprPrefixName meth <+> dcolon <+> ppr ty)
 
-misplacedInstSig :: [Located Name] -> LHsType Name -> SDoc
-misplacedInstSig names hs_ty
+misplacedInstSig :: Name -> LHsType Name -> SDoc
+misplacedInstSig name hs_ty
   = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
-              2 (hang (hsep $ punctuate comma (map (pprPrefixName . unLoc) names))
+              2 (hang (pprPrefixName name)
                     2 (dcolon <+> ppr hs_ty))
          , ptext (sLit "(Use -XInstanceSigs to allow this)") ]
 
@@ -969,46 +996,47 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                   (spec_inst_prags, prag_fn)
                   op_items (VanillaInst binds sigs standalone_deriv)
-  = do { mapM_ (checkInstSig clas inst_tys) sigs
-       ; mapAndUnzipM tc_item op_items }
+  = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
+       ; let hs_sig_fn = mkHsSigFun sigs
+       ; mapAndUnzipM (tc_item hs_sig_fn) op_items }
   where
     ----------------------
-    tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
-    tc_item (sel_id, dm_info)
+    tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
+    tc_item sig_fn (sel_id, dm_info)
       = case findMethodBind (idName sel_id) binds of
-            Just user_bind -> tc_body sel_id standalone_deriv user_bind
+            Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind
             Nothing        -> traceTc "tc_def" (ppr sel_id) >> 
-                              tc_default sel_id dm_info
+                              tc_default sig_fn sel_id dm_info
 
     ----------------------
-    tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
-    tc_body sel_id generated_code rn_bind
+    tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
+    tc_body sig_fn sel_id generated_code rn_bind
       = add_meth_ctxt sel_id generated_code rn_bind $
-        do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
-                                                   inst_tys sel_id
-           ; let sel_name = idName sel_id
-                 prags = prag_fn (idName sel_id)
+        do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
+           ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $
+                                          mkMethIds sig_fn clas tyvars dfun_ev_vars
+                                                    inst_tys sel_id
+           ; let prags = prag_fn (idName sel_id)
            ; meth_id1 <- addInlinePrags meth_id prags
            ; spec_prags <- tcSpecPrags meth_id1 prags
            ; bind <- tcInstanceMethodBody InstSkol
                           tyvars dfun_ev_vars
-                          meth_id1 local_meth_id 
-                          (mk_meth_sig_fn sel_name)
+                          meth_id1 local_meth_sig
                           (mk_meth_spec_prags meth_id1 spec_prags)
                           rn_bind
            ; return (meth_id1, bind) }
 
     ----------------------
-    tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+    tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id)
 
-    tc_default sel_id (GenDefMeth dm_name)
+    tc_default sig_fn sel_id (GenDefMeth dm_name)
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
-           ; tc_body sel_id False {- Not generated code? -} meth_bind }
+           ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind }
 
-    tc_default sel_id NoDefMeth     -- No default method at all
+    tc_default sig_fn sel_id NoDefMeth     -- No default method at all
       = do { traceTc "tc_def: warn" (ppr sel_id)
            ; warnMissingMethodOrAT "method" (idName sel_id)
-           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
+           ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
                                          inst_tys sel_id
            ; return (meth_id, mkVarBind meth_id $
                               mkLHsWrap lam_wrapper error_rhs) }
@@ -1020,7 +1048,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
         error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
 
-    tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
+    tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
       = do {   -- Build the typechecked version directly,
                  -- without calling typecheck_method;
                  -- see Note [Default methods in instances]
@@ -1033,13 +1061,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
            ; let self_ev_bind = EvBind self_dict
                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars)
 
-           ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+           ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
                                                    inst_tys sel_id
            ; dm_id <- tcLookupId dm_name
            ; let dm_inline_prag = idInlinePragma dm_id
                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
                        HsVar dm_id
 
+                 local_meth_id = sig_id local_meth_sig
                  meth_bind = mkVarBind local_meth_id (L loc rhs)
                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
                         -- Copy the inline pragma (if any) from the default
@@ -1081,19 +1110,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
            = [ L loc (SpecPrag meth_id wrap inl)
              | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]
 
-    loc    = getSrcSpan dfun_id
-    sig_fn = mkSigFun sigs
-    mk_meth_sig_fn sel_name _meth_name 
-       = case sig_fn sel_name of 
-            Nothing -> Just ([],loc)
-            Just r  -> Just r 
-        -- The orElse 'Just' says "yes, in effect there's always a type sig"
-        -- But there are no scoped type variables from local_method_id
-        -- Only the ones from the instance decl itself, which are already
-        -- in scope.  Example:
-        --      class C a where { op :: forall b. Eq b => ... }
-        --      instance C [c] where { op = <rhs> }
-        -- In <rhs>, 'c' is scope but 'b' is not!
+    loc = getSrcSpan dfun_id
 
         -- For instance decls that come from standalone deriving clauses
         -- we want to print out the full source code if there's an error
@@ -1144,14 +1161,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
      -- co : [p] ~ T p
      co = mkTcSymCo (mkTcInstCos coi (mkTyVarTys tyvars))
+     sig_fn = emptyHsSigs
 
      ----------------
      tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
      tc_item (rep_ev_binds, rep_d) (sel_id, _)
-       = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
-                                                    inst_tys sel_id
+       = do { (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
+                                                     inst_tys sel_id
 
-            ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
+            ; let meth_rhs      = wrapId (mk_op_wrapper sel_id rep_d) sel_id
+                  local_meth_id = sig_id local_meth_sig
                   meth_bind = mkVarBind local_meth_id (L loc meth_rhs)
                   export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
                                , abe_mono = local_meth_id, abe_prags = noSpecPrags }
@@ -1175,23 +1194,6 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                               `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
 
 ----------------------
-mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
-mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
-  = do  { uniq <- newUnique
-        ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
-        ; local_meth_name <- newLocalName sel_name
-                  -- Base the local_meth_name on the selector name, becuase
-                  -- type errors from tcInstanceMethodBody come from here
-
-        ; let meth_id       = mkLocalId meth_name meth_ty
-              local_meth_id = mkLocalId local_meth_name local_meth_ty
-        ; return (meth_id, local_meth_id) }
-  where
-    local_meth_ty = instantiateMethod clas sel_id inst_tys
-    meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
-    sel_name = idName sel_id
-
-----------------------
 wrapId :: HsWrapper -> id -> HsExpr id
 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
 
index 3e58013..5932934 100644 (file)
@@ -633,17 +633,22 @@ solveWithIdentity d eqv wd tv xi
                              text "Right Kind is     : " <+> ppr (typeKind xi)
                             ]
 
-       ; setWantedTyBind tv xi
-       ; let refl_xi = mkTcReflCo xi
+       ; let xi' = defaultKind xi      
+               -- We only instantiate kind unification variables
+               -- with simple kinds like *, not OpenKind or ArgKind
+               -- cf TcUnify.uUnboundKVar
+
+       ; setWantedTyBind tv xi'
+       ; let refl_xi = mkTcReflCo xi'
 
        ; let solved_fl = mkSolvedFlavor wd UnkSkol (EvCoercion refl_xi) 
-       ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi
+       ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi' refl_xi
 
        ; when (isWanted wd) $ do { _ <- setEqBind eqv refl_xi wd; return () }
            -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
        ; return $ SPSolved (CTyEqCan { cc_id     = eqv_given
                                      , cc_flavor = solved_fl
-                                     , cc_tyvar  = tv, cc_rhs = xi, cc_depth = d }) }
+                                     , cc_tyvar  = tv, cc_rhs = xi', cc_depth = d }) }
 \end{code}
 
 
@@ -1551,7 +1556,7 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
                                       ; return $ 
                                         SomeTopInt { tir_rule = "Fun/Top (given)"
                                                    , tir_new_item = ContinueWith workItem } }
-                       Derived {} -> do { evc <- newEvVar fl (mkEqPred (xi, rhs_ty))
+                       Derived {} -> do { evc <- newEvVar fl (mkTcEqPred xi rhs_ty)
                                         ; let eqv' = evc_the_evvar evc
                                         ; when (isNewEvVar evc) $ 
                                             (let ct = CNonCanonical { cc_id  = eqv'
index 518a403..f045287 100644 (file)
@@ -24,7 +24,7 @@ module TcMType (
   newFlexiTyVar,
   newFlexiTyVarTy,             -- Kind -> TcM TcType
   newFlexiTyVarTys,            -- Int -> Kind -> TcM [TcType]
-  newMetaKindVar, newMetaKindVars,
+  newMetaKindVar, newMetaKindVars, mkKindSigVar,
   mkTcTyVarName,
 
   newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
@@ -60,8 +60,8 @@ module TcMType (
   --------------------------------
   -- Zonking
   zonkType, zonkKind, zonkTcPredType, 
-  skolemiseUnboundMetaTyVar,
-  zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
+  skolemiseSigTv, skolemiseUnboundMetaTyVar,
+  zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkSigTyVar,
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
 
@@ -116,12 +116,16 @@ import Data.List        ( (\\), partition, mapAccumL )
 
 \begin{code}
 newMetaKindVar :: TcM TcKind
-newMetaKindVar = do    { uniq <- newUnique
-               ; ref <- newMutVar Flexi
-               ; return (mkTyVarTy (mkMetaKindVar uniq ref)) }
+newMetaKindVar = do { uniq <- newUnique
+                   ; ref <- newMutVar Flexi
+                   ; return (mkTyVarTy (mkMetaKindVar uniq ref)) }
 
 newMetaKindVars :: Int -> TcM [TcKind]
 newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())
+
+mkKindSigVar :: Name -> KindVar
+-- Use the specified name; don't clone it
+mkKindSigVar n = mkTcTyVar n superKind (SkolemTv False)
 \end{code}
 
 
@@ -151,7 +155,7 @@ newEvVar ty = do { name <- newName (predTypeOccName ty)
 newEq :: TcType -> TcType -> TcM EvVar
 newEq ty1 ty2
   = do { name <- newName (mkVarOccFS (fsLit "cobox"))
-       ; return (mkLocalId name (mkEqPred (ty1, ty2))) }
+       ; return (mkLocalId name (mkTcEqPred ty1 ty2)) }
 
 newIP :: IPName Name -> TcType -> TcM IpId
 newIP ip ty
@@ -180,7 +184,7 @@ predTypeOccName ty = case classifyPredType ty of
 %************************************************************************
 
 \begin{code}
-tcInstType :: ([TyVar] -> TcM [TcTyVar])               -- How to instantiate the type variables
+tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar]))     -- How to instantiate the type variables
           -> TcType                                    -- Type to instantiate
           -> TcM ([TcTyVar], TcThetaType, TcType)      -- Result
                -- (type vars (excl coercion vars), preds (incl equalities), rho)
@@ -192,14 +196,8 @@ tcInstType inst_tyvars ty
                         in
                         return ([], theta, tau)
 
-       (tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars
-
-                           ; let  tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
-                               -- Either the tyvars are freshly made, by inst_tyvars,
-                                -- or any nested foralls have different binders.
-                                -- Either way, zipTopTvSubst is ok
-
-                           ; let  (theta, tau) = tcSplitPhiTy (substTy tenv rho)
+       (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars
+                           ; let (theta, tau) = tcSplitPhiTy (substTy subst rho)
                            ; return (tyvars', theta, tau) }
 
 tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType)
@@ -208,12 +206,12 @@ tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType)
 -- be in the type environment: it is lexically scoped.
 tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty
 
-tcSuperSkolTyVars :: [TyVar] -> [TcTyVar]
+tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar])
 -- Make skolem constants, but do *not* give them new names, as above
 -- Moreover, make them "super skolems"; see comments with superSkolemTv
 -- see Note [Kind substitution when instantiating]
 -- Precondition: tyvars should be ordered (kind vars first)
-tcSuperSkolTyVars = snd . mapAccumL tcSuperSkolTyVar (mkTopTvSubst [])
+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTvSubst [])
 
 tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar)
 tcSuperSkolTyVar subst tv
@@ -239,14 +237,11 @@ tcInstSkolTyVar overlappable subst tyvar
     occ      = nameOccName old_name
     kind     = substTy subst (tyVarKind tyvar)
 
-tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
--- Precondition: tyvars should be ordered (kind vars first)
--- see Note [Kind substitution when instantiating]
-tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol)
-
 -- Wrappers
-tcInstSkolTyVars, tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
-tcInstSkolTyVars      = fmap snd . tcInstSkolTyVars' False (mkTopTvSubst [])
+tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
+tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst [])
+
+tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
 tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True  (mkTopTvSubst [])
 
 tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX
@@ -254,17 +249,24 @@ tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX
 tcInstSkolTyVarsX      subst = tcInstSkolTyVars' False subst
 tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True  subst
 
+tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
+-- Precondition: tyvars should be ordered (kind vars first)
+-- see Note [Kind substitution when instantiating]
+tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol)
+
 tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
 -- Binding location comes from the monad
 tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
 
-tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
+tcInstSigTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
 -- Make meta SigTv type variables for patten-bound scoped type varaibles
 -- We use SigTvs for them, so that they can't unify with arbitrary types
 -- Precondition: tyvars should be ordered (kind vars first)
 -- see Note [Kind substitution when instantiating]
-tcInstSigTyVars = fmap snd . mapAccumLM tcInstSigTyVar (mkTopTvSubst [])
+tcInstSigTyVars = mapAccumLM tcInstSigTyVar (mkTopTvSubst [])
+       -- The tyvars are freshly made, by tcInstSigTyVar
+        -- So mkTopTvSubst [] is ok
 
 tcInstSigTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar)
 tcInstSigTyVar subst tv
@@ -481,28 +483,31 @@ the environment.
 tcGetGlobalTyVars :: TcM TcTyVarSet
 tcGetGlobalTyVars
   = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
-       ; gbl_tvs <- readMutVar gtv_var
-       ; tys     <- mapM zonk_tv (varSetElems gbl_tvs)
-       ; let gbl_tvs' = tyVarsOfTypes tys
+       ; gbl_tvs  <- readMutVar gtv_var
+       ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs
        ; writeMutVar gtv_var gbl_tvs'
        ; return gbl_tvs' }
   where
-    zonk_tv tv | isTcTyVar tv = zonkTcTyVar tv
-               | otherwise    = return (mkTyVarTy tv)
-    -- Hackily, the global tyvars can contain non-TcTyVars
-    -- These are added (only) in TcHsType.tcTyClTyVars, but it seems
-    -- painful to make them into TcTyVars there
 \end{code}
 
 -----------------  Type variables
 
 \begin{code}
+zonkTyVar :: TyVar -> TcM TcType
+-- Works on TyVars and TcTyVars
+zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv
+             | otherwise    = return (mkTyVarTy tv)
+   -- Hackily, when typechecking type and class decls
+   -- we have TyVars in scopeadded (only) in 
+   -- TcHsType.tcTyClTyVars, but it seems
+   -- painful to make them into TcTyVars there
+
+zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet
+zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars)
+
 zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
 zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
 
-zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet
-zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars)
-
 -----------------  Types
 zonkTcType :: TcType -> TcM TcType
 -- Simply look through all Flexis
@@ -640,6 +645,17 @@ skolemiseUnboundMetaTyVar tv details
 
         ; writeMetaTyVar tv (mkTyVarTy final_tv)
         ; return final_tv }
+
+skolemiseSigTv :: TcTyVar -> TcM TcTyVar
+-- In TcBinds we create SigTvs for type signatures
+-- but for singleton groups we want them to really be skolems
+-- which do not unify with each other
+skolemiseSigTv tv  
+  = ASSERT2( isSigTyVar tv, ppr tv )
+    do { writeMetaTyVarRef tv (metaTvRef tv) (mkTyVarTy skol_tv)
+       ; return skol_tv }
+  where
+    skol_tv = setTcTyVarDetails tv (SkolemTv False)
 \end{code}
 
 \begin{code}
@@ -803,12 +819,12 @@ zonkType zonk_tc_tyvar ty
 
        -- The two interesting cases!
     go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
-                      | otherwise       = TyVarTy <$> updateTyVarKindM zonkTcKind tyvar
+                      | otherwise       = TyVarTy <$> updateTyVarKindM go tyvar
                -- Ordinary (non Tc) tyvars occur inside quantified types
 
     go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                              ty' <- go ty
-                             tyvar' <- updateTyVarKindM zonkTcKind tyvar
+                             tyvar' <- updateTyVarKindM go tyvar
                              return (ForAllTy tyvar' ty')
 \end{code}
 
@@ -869,71 +885,74 @@ expectedKindInCtxt GhciCtxt       = Nothing
 expectedKindInCtxt ResSigCtxt     = Just openTypeKind
 expectedKindInCtxt ExprSigCtxt    = Just openTypeKind
 expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind
+expectedKindInCtxt InstDeclCtxt   = Just constraintKind
+expectedKindInCtxt SpecInstCtxt   = Just constraintKind
 expectedKindInCtxt _              = Just argTypeKind
 
 checkValidType :: UserTypeCtxt -> Type -> TcM ()
 -- Checks that the type is valid for the given context
-checkValidType ctxt ty = do
-    traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
-    unboxed         <- xoptM Opt_UnboxedTuples
-    rank2           <- xoptM Opt_Rank2Types
-    rankn           <- xoptM Opt_RankNTypes
-    polycomp        <- xoptM Opt_PolymorphicComponents
-    constraintKinds <- xoptM Opt_ConstraintKinds
-    let 
-       gen_rank n | rankn     = ArbitraryRank
-                  | rank2     = Rank 2
-                  | otherwise = Rank n
-       rank
-         = case ctxt of
-                DefaultDeclCtxt-> MustBeMonoType
-                ResSigCtxt     -> MustBeMonoType
-                LamPatSigCtxt  -> gen_rank 0
-                BindPatSigCtxt -> gen_rank 0
-                TySynCtxt _    -> gen_rank 0
-
-                ExprSigCtxt    -> gen_rank 1
-                FunSigCtxt _   -> gen_rank 1
-                InfSigCtxt _   -> ArbitraryRank        -- Inferred type
-                ConArgCtxt _   | polycomp -> gen_rank 2
-                                -- We are given the type of the entire
-                                -- constructor, hence rank 1
-                               | otherwise -> gen_rank 1
-
-                ForSigCtxt _   -> gen_rank 1
-                SpecInstCtxt   -> gen_rank 1
+-- Not used for instance decls; checkValidInstance instead
+checkValidType ctxt ty 
+  = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
+       ; unboxed         <- xoptM Opt_UnboxedTuples
+       ; rank2           <- xoptM Opt_Rank2Types
+       ; rankn           <- xoptM Opt_RankNTypes
+       ; polycomp        <- xoptM Opt_PolymorphicComponents
+       ; constraintKinds <- xoptM Opt_ConstraintKinds
+       ; let gen_rank n | rankn     = ArbitraryRank
+                       | rank2     = Rank 2
+                       | otherwise = Rank n
+            rank
+              = case ctxt of
+                DefaultDeclCtxt-> MustBeMonoType
+                ResSigCtxt     -> MustBeMonoType
+                LamPatSigCtxt  -> gen_rank 0
+                BindPatSigCtxt -> gen_rank 0
+                TySynCtxt _    -> gen_rank 0
+
+                ExprSigCtxt    -> gen_rank 1
+                FunSigCtxt _   -> gen_rank 1
+                InfSigCtxt _   -> ArbitraryRank        -- Inferred type
+                ConArgCtxt _   | polycomp -> gen_rank 2
+                                     -- We are given the type of the entire
+                                     -- constructor, hence rank 1
+                               | otherwise -> gen_rank 1
+
+                ForSigCtxt _   -> gen_rank 1
+                SpecInstCtxt   -> gen_rank 1
                  ThBrackCtxt    -> gen_rank 1
-                GhciCtxt       -> ArbitraryRank
+                GhciCtxt       -> ArbitraryRank
                  _              -> panic "checkValidType"
-                                     -- Can't happen; not used for *user* sigs
+                                          -- Can't happen; not used for *user* sigs
 
-       actual_kind = typeKind ty
+            actual_kind = typeKind ty
 
-        kind_ok = case expectedKindInCtxt ctxt of
-                    Nothing -> True
-                    Just k  -> tcIsSubKind actual_kind k
+             kind_ok = case expectedKindInCtxt ctxt of
+                         Nothing -> True
+                         Just k  -> tcIsSubKind actual_kind k
        
-       ubx_tup 
-         | not unboxed = UT_NotOk
-         | otherwise   = case ctxt of
-                          TySynCtxt _ -> UT_Ok
-                          ExprSigCtxt -> UT_Ok
-                          ThBrackCtxt -> UT_Ok
-                          GhciCtxt    -> UT_Ok
-                          _           -> UT_NotOk
+            ubx_tup 
+              | not unboxed = UT_NotOk
+              | otherwise   = case ctxt of
+                                  TySynCtxt _ -> UT_Ok
+                                  ExprSigCtxt -> UT_Ok
+                                  ThBrackCtxt -> UT_Ok
+                                  GhciCtxt    -> UT_Ok
+                                  _           -> UT_NotOk
 
        -- Check the internal validity of the type itself
-    check_type rank ubx_tup ty
+       ; check_type rank ubx_tup ty
 
        -- Check that the thing has kind Type, and is lifted if necessary
        -- Do this second, because we can't usefully take the kind of an 
        -- ill-formed type such as (a~Int)
-    checkTc kind_ok (kindErr actual_kind)
+       ; checkTc kind_ok (kindErr actual_kind)
 
         -- Check that the thing does not have kind Constraint,
         -- if -XConstraintKinds isn't enabled
-    unless constraintKinds
-      $ checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty)
+       ; unless constraintKinds $
+         checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty)
+       }
 
 checkValidMonoType :: Type -> TcM ()
 checkValidMonoType ty = check_mono_type MustBeMonoType ty
@@ -1184,7 +1203,7 @@ check_pred_ty' dflags _ctxt (EqPred ty1 ty2)
   = do {       -- Equational constraints are valid in all contexts if type
                -- families are permitted
        ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) 
-                 (eqPredTyErr (mkEqPred (ty1, ty2)))
+                 (eqPredTyErr (mkEqPred ty1 ty2))
 
                -- Check the form of the argument types
        ; checkValidMonoType ty1
@@ -1458,26 +1477,27 @@ We can also have instances for functions: @instance Foo (a -> b) ...@.
 
 \begin{code}
 checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
-checkValidInstHead ctxt clas tys
+checkValidInstHead ctxt clas cls_args
   = do { dflags <- getDynFlags
 
            -- Check language restrictions; 
            -- but not for SPECIALISE isntance pragmas
+       ; let ty_args = dropWhile isKind cls_args
        ; unless spec_inst_prag $
          do { checkTc (xopt Opt_TypeSynonymInstances dflags ||
-                       all tcInstHeadTyNotSynonym tys)
+                       all tcInstHeadTyNotSynonym ty_args)
                  (instTypeErr pp_pred head_type_synonym_msg)
             ; checkTc (xopt Opt_FlexibleInstances dflags ||
-                       all tcInstHeadTyAppAllTyVars tys)
+                       all tcInstHeadTyAppAllTyVars ty_args)
                  (instTypeErr pp_pred head_type_args_tyvars_msg)
             ; checkTc (xopt Opt_MultiParamTypeClasses dflags ||
-                       isSingleton (dropWhile isKind tys))  -- IA0_NOTE: only count type arguments
+                       isSingleton ty_args)  -- Only count type arguments
                  (instTypeErr pp_pred head_one_type_msg) }
 
          -- May not contain type family applications
-       ; mapM_ checkTyFamFreeness tys
+       ; mapM_ checkTyFamFreeness ty_args
 
-       ; mapM_ checkValidMonoType tys
+       ; mapM_ checkValidMonoType ty_args
        -- For now, I only allow tau-types (not polytypes) in 
        -- the head of an instance decl.  
        --      E.g.  instance C (forall a. a->a) is rejected
@@ -1488,7 +1508,7 @@ checkValidInstHead ctxt clas tys
   where
     spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
 
-    pp_pred = pprClassPred clas tys
+    pp_pred = pprClassPred clas cls_args
     head_type_synonym_msg = parens (
                 text "All instance types must be of the form (T t1 ... tn)" $$
                 text "where T is not a synonym." $$
@@ -1540,13 +1560,16 @@ validDerivPred tv_set ty = case getClassPredTys_maybe ty of
 %************************************************************************
 
 \begin{code}
-checkValidInstance :: UserTypeCtxt -> LHsType Name -> [TyVar] -> ThetaType
-                   -> Class -> [TcType] -> TcM ()
-checkValidInstance ctxt hs_type tyvars theta clas inst_tys
-  = setSrcSpan (getLoc hs_type) $
+checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type
+                   -> TcM ([TyVar], ThetaType, Class, [Type])
+checkValidInstance ctxt hs_type ty
+  = do { let (tvs, theta, tau) = tcSplitSigmaTy ty
+       ; case getClassPredTys_maybe tau of {
+           Nothing          -> failWithTc (ptext (sLit "Malformed instance type")) ;
+           Just (clas,inst_tys)  -> 
     do  { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
         ; checkValidTheta ctxt theta
-       ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
+       ; checkAmbiguity tvs theta (tyVarsOfTypes inst_tys)
 
        -- Check that instance inference will terminate (if we care)
        -- For Haskell 98 this will already have been done by checkValidTheta,
@@ -1558,7 +1581,7 @@ checkValidInstance ctxt hs_type tyvars theta clas inst_tys
        -- The Coverage Condition
        ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
                  (instTypeErr (pprClassPred clas inst_tys) msg)
-        }
+        ; return (tvs, theta, clas, inst_tys) } } }
   where
     msg  = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
                         undecidableMsg])
index 41647e7..f237b67 100644 (file)
@@ -138,12 +138,11 @@ data TcSigInfo
   = TcSigInfo {
         sig_id     :: TcId,         --  *Polymorphic* binder for this value...
 
-        sig_scoped :: [Name],      -- Scoped type variables
-               -- 1-1 correspondence with a prefix of sig_tvs
-               -- However, may be fewer than sig_tvs; 
-               -- see Note [More instantiated than scoped]
-        sig_tvs    :: [TcTyVar],    -- Instantiated type variables
-                                    -- See Note [Instantiate sig]
+        sig_tvs    :: [(Maybe Name, TcTyVar)],    
+                           -- Instantiated type and kind variables
+                           -- Just n <=> this skolem is lexically in scope with name n
+                           -- See Note [Kind vars in sig_tvs]
+                          -- See Note [More instantiated than scoped] in TcBinds
 
         sig_theta  :: TcThetaType,  -- Instantiated theta
 
@@ -158,6 +157,16 @@ instance Outputable TcSigInfo where
         = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau
 \end{code}
 
+Note [Kind vars in sig_tvs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With kind polymorphism a signature like
+  f :: forall f a. f a -> f a
+may actuallly give rise to 
+  f :: forall k. forall (f::k -> *) (a:k). f a -> f a
+So the sig_tvs will be [k,f,a], but only f,a are scoped.
+So the scoped ones are not necessarily the *inital* ones!
+
+
 Note [sig_tau may be polymorphic]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Note that "sig_tau" might actually be a polymorphic type,
index 8a5aab5..f22c988 100644 (file)
@@ -1458,7 +1458,7 @@ tcRnType hsc_env ictxt normalise rdr_type
   = initTcPrintErrors hsc_env iNTERACTIVE $
     setInteractiveContext hsc_env ictxt $ do {
 
-    rn_type <- rnLHsType GHCiCtx rdr_type ;
+    (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ;
     failIfErrsM ;
 
         -- Now kind-check the type
index 77a1230..1d8bdd7 100644 (file)
@@ -221,6 +221,9 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
 %************************************************************************
 
 \begin{code}
+discardResult :: TcM a -> TcM ()
+discardResult a = a >> return ()
+
 getTopEnv :: TcRnIf gbl lcl HscEnv
 getTopEnv = do { env <- getEnv; return (env_top env) }
 
index b353943..e19ca35 100644 (file)
@@ -569,8 +569,8 @@ data TcTyThing
        tct_closed :: TopLevelFlag,   -- See Note [Bindings with closed types]
        tct_level  :: ThLevel }
 
-  | ATyVar  Name TcTyVar       -- The type to which the lexically scoped type vaiable
-                               -- is currently refined. We only need the Name
+  | ATyVar  Name TcTyVar       -- The type variable to which the lexically scoped type 
+                               -- variable is bound. We only need the Name
                                -- for error-message purposes; it is the corresponding
                                -- Name in the domain of the envt
 
@@ -919,9 +919,9 @@ ctPred (CNonCanonical { cc_id = v }) = evVarPred v
 ctPred (CDictCan { cc_class = cls, cc_tyargs = xis }) 
   = mkClassPred cls xis
 ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) 
-  = mkEqPred (mkTyVarTy tv, xi)
+  = mkTcEqPred (mkTyVarTy tv) xi
 ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) 
-  = mkEqPred(mkTyConApp fn xis1, xi2)
+  = mkTcEqPred (mkTyConApp fn xis1) xi2
 ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) 
   = mkIPPred nm xi
 ctPred (CIrredEvCan { cc_ty = xi }) = xi
index f4dafcb..bd58c3a 100644 (file)
@@ -95,7 +95,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
 
             -- Now figure out what to quantify over
             -- c.f. TcSimplify.simplifyInfer
-       ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs
+       ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs
        ; gbl_tvs           <- tcGetGlobalTyVars             -- Already zonked
        ; let extra_bound_tvs = zonked_forall_tvs            
                                       `minusVarSet` gbl_tvs
@@ -124,8 +124,8 @@ tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs)
 --             a::*, x :: a->a
   = do { let ctxt = FunSigCtxt (unLoc var)
        ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty
-        ; let skol_tvs = tcSuperSkolTyVars tyvars
-             id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty
+        ; let (subst, skol_tvs) = tcSuperSkolTyVars tyvars
+             id_ty = substTy subst ty
              id = mkLocalId (unLoc var) id_ty
 
              -- The type variables scope over subsequent bindings; yuk
index 964a3d3..5f87205 100644 (file)
@@ -1112,7 +1112,7 @@ checkWellStagedDFun pred dfun_id loc
     bind_lvl = TcM.topIdLvl dfun_id
 
 pprEq :: TcType -> TcType -> SDoc
-pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2)
+pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2
 
 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
 isTouchableMetaTyVar tv 
@@ -1351,7 +1351,7 @@ newGivenEqVar fl ty1 ty2 co
 
 newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated
 newEqVar fl ty1 ty2 
-  = do { let pred = mkEqPred (ty1,ty2)
+  = do { let pred = mkTcEqPred ty1 ty2
        ; v <- newEvVar fl pred 
        ; traceTcS "newEqVar" (ppr v <+> dcolon <+> ppr pred)
        ; return v }
index ae948b5..eff1890 100644 (file)
@@ -97,20 +97,19 @@ simplifyDeriv :: CtOrigin
 -- Simplify 'wanted' as much as possibles
 -- Fail if not possible
 simplifyDeriv orig pred tvs theta 
-  = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize
+  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
                -- The constraint solving machinery 
                -- expects *TcTyVars* not TyVars.  
                -- We use *non-overlappable* (vanilla) skolems
                -- See Note [Overlap and deriving]
 
-       ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols
-             subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
+       ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
              skol_set   = mkVarSet tvs_skols
             doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred)
 
        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
 
-       ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted)
+       ; traceTc "simplifyDeriv" (pprTvBndrs tvs $$ ppr theta $$ ppr wanted)
        ; (residual_wanted, _ev_binds1)
              <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $
                 solveWanteds $ mkFlatWC wanted
@@ -248,13 +247,14 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
 
   | otherwise
   = do { zonked_wanteds <- zonkWC wanteds
-       ; zonked_taus    <- zonkTcTypes (map snd name_taus)
        ; gbl_tvs        <- tcGetGlobalTyVars
+       ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus))
        ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
 
        ; traceTc "simplifyInfer {"  $ vcat
              [ ptext (sLit "names =") <+> ppr (map fst name_taus)
-             , ptext (sLit "taus (zonked) =") <+> ppr zonked_taus
+             , ptext (sLit "taus =") <+> ppr (map snd name_taus)
+             , ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs
              , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs
              , ptext (sLit "closed =") <+> ppr _top_lvl
              , ptext (sLit "apply_mr =") <+> ppr apply_mr
@@ -266,8 +266,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
             -- Then split the constraints on the baisis of those tyvars
             -- to avoid unnecessarily simplifying a class constraint
             -- See Note [Avoid unecessary constraint simplification]
-       ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus
-             proto_qtvs = growWanteds gbl_tvs zonked_wanteds $
+       ; let proto_qtvs = growWanteds gbl_tvs zonked_wanteds $
                           zonked_tau_tvs `minusVarSet` gbl_tvs
              (perhaps_bound, surely_free)
                         = partitionBag (quantifyMe proto_qtvs) (wc_flat zonked_wanteds)
@@ -301,7 +300,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
             -- Split again simplified_perhaps_bound, because some unifications 
             -- may have happened, and emit the free constraints. 
        ; gbl_tvs        <- tcGetGlobalTyVars
-       ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs
+       ; zonked_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs
        ; zonked_flats <- zonkCts (wc_flat simpl_results)
        ; let init_tvs       = zonked_tau_tvs `minusVarSet` gbl_tvs
              poly_qtvs       = growWantedEVs gbl_tvs zonked_flats init_tvs
@@ -786,6 +785,11 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols
                 -- See Note [Solving Family Equations]
                 -- NB: remaining_flats has already had subst applied
 
+       ; traceTcS "solveWanteds finished with" $
+                 vcat [ text "remaining_unsolved_flats =" <+> ppr remaining_unsolved_flats
+                      , text "subst =" <+> ppr subst
+                      ]
+
        ; return $ 
          WC { wc_flat  = mapBag (substCt subst) remaining_unsolved_flats
             , wc_impl  = mapBag (substImplication subst) unsolved_implics
index e7ddd5b..63501e9 100644 (file)
@@ -7,7 +7,7 @@ TcSplice: Template Haskell splices
 
 
 \begin{code}
-module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
+module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  lookupThName_maybe,
                  runQuasiQuoteExpr, runQuasiQuotePat,
                  runQuasiQuoteDecl, runQuasiQuoteType,
@@ -286,7 +286,7 @@ The predicate we use is TcEnv.thTopLevelId.
 tcBracket     :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId)
 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 tcSpliceExpr  :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
-kcSpliceType  :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
+tcSpliceType  :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
         -- None of these functions add constraints to the LIE
 
 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
@@ -302,7 +302,7 @@ runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
 tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
 tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
-kcSpliceType  x fvs = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
+tcSpliceType  x fvs = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
 
 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
 
@@ -517,12 +517,12 @@ tcTopSpliceExpr tc_action
 Very like splicing an expression, but we don't yet share code.
 
 \begin{code}
-kcSpliceType splice@(HsSplice name hs_expr) fvs
+tcSpliceType (HsSplice name hs_expr) _
   = setSrcSpan (getLoc hs_expr) $ do
     { stage <- getStage
     ; case stage of {
-        Splice -> kcTopSpliceType hs_expr ;
-        Comp   -> kcTopSpliceType hs_expr ;
+        Splice -> tcTopSpliceType hs_expr ;
+        Comp   -> tcTopSpliceType hs_expr ;
 
         Brack pop_level ps_var lie_var -> do
            -- See Note [How brackets and nested splices are handled]
@@ -541,12 +541,13 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs
     -- but $(h 4) :: a  i.e. any type, of any kind
 
     ; kind <- newMetaKindVar
-    ; return (HsSpliceTy splice fvs kind, kind) 
+    ; ty <- newFlexiTyVarTy kind
+    ; return (ty, kind)
     }}}
 
-kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
+tcTopSpliceType :: LHsExpr Name -> TcM (TcType, TcKind)
 -- Note [How top-level splices are handled]
-kcTopSpliceType expr
+tcTopSpliceType expr
   = do  { meta_ty <- tcMetaTy typeQTyConName
 
         -- Typecheck the expression
@@ -560,9 +561,8 @@ kcTopSpliceType expr
         -- otherwise the type checker just gives more spurious errors
         ; addErrCtxt (spliceResultDoc expr) $ do 
         { let doc = SpliceTypeCtx hs_ty2
-        ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
-        ; (ty4, kind) <- kcLHsType hs_ty3
-        ; return (unLoc ty4, kind) }}
+        ; (hs_ty3, _fvs) <- checkNoErrs (rnLHsType doc hs_ty2)
+        ; tcLHsType hs_ty3 }}
 \end{code}
 
 %************************************************************************
@@ -1005,9 +1005,9 @@ reifyInstances th_nm th_tys
                              <+> int tc_arity <> rparen))
            ; loc <- getSrcSpanM
            ; rdr_tys <- mapM (cvt loc) th_tys    -- Convert to HsType RdrName
-           ; rn_tys  <- rnLHsTypes doc rdr_tys   -- Rename  to HsType Name
-           ; (tys, _res_k) <- kcApps tc (tyConKind tc) rn_tys
-           ; mapM dsHsType tys }
+           ; (rn_tys, _fvs)  <- rnLHsTypes doc rdr_tys   -- Rename  to HsType Name
+           ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys
+           ; return tys }
 
     cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
     cvt loc th_ty = case convertToHsType loc th_ty of
index 18a31b0..de14aa3 100644 (file)
@@ -1,12 +1,12 @@
 \begin{code}
 module TcSplice where
 import HsSyn    ( HsSplice, HsBracket, HsQuasiQuote,
-                  HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl )
+                  HsExpr, LHsType, LHsExpr, LPat, LHsDecl )
 import Name     ( Name )
 import NameSet  ( FreeVars )
 import RdrName  ( RdrName )
 import TcRnTypes( TcM, TcId )
-import TcType   ( TcRhoType, TcKind )
+import TcType   ( TcRhoType, TcType, TcKind )
 import Annotations ( Annotation, CoreAnnTarget )
 import qualified Language.Haskell.TH as TH
 
@@ -14,8 +14,7 @@ tcSpliceExpr :: HsSplice Name
              -> TcRhoType
              -> TcM (HsExpr TcId)
 
-kcSpliceType :: HsSplice Name -> FreeVars
-             -> TcM (HsType Name, TcKind)
+tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
 
 tcBracket :: HsBracket Name 
           -> TcRhoType
index d02f0a8..b04f415 100644 (file)
@@ -31,6 +31,7 @@ import BuildTyCl
 import TcUnify
 import TcRnMonad
 import TcEnv
+import TcHsSyn
 import TcBinds( tcRecSelBinds )
 import TcTyDecls
 import TcClassDcl
@@ -77,7 +78,6 @@ import Data.List
 
 Note [Grouping of type and class declarations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly
 connected component of mutually dependent types and classes. We kind check and
 type check each group separately to enhance kind polymorphism. Take the
@@ -219,11 +219,11 @@ So we infer their kinds in dependency order
 We need to kind check all types in the mutually recursive group
 before we know the kind of the type variables.  For example:
 
-class C a where
-   op :: D b => a -> b -> b
+  class C a where
+     op :: D b => a -> b -> b
 
-class D c where
-   bop :: (Monad c) => ...
+  class D c where
+     bop :: (Monad c) => ...
 
 Here, the kind of the locally-polymorphic type variable "b"
 depends on *all the uses of class D*.  For example, the use of
@@ -276,7 +276,7 @@ kcTyClGroup decls
         ; setLclEnv tcl_env $  do
 
           -- Step 3: kind-check the synonyms
-        { mapM_ (wrapLocM kcTyClDecl) non_syn_decls
+        { mapM_ kcLTyClDecl non_syn_decls
 
             -- Step 4: generalisation
             -- Kind checking done for this group
@@ -304,28 +304,18 @@ getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)]
 --                       of the definition (and probably including
 --                       kind unification variables)
 --      Example: data T a b = ...
---      return (T, kv1 -> kv2 -> *)
+--      return (T, kv1 -> kv2 -> kv3)
 --
 -- ALSO for each datacon, return (dc, ANothing)
 --      See Note [ANothing] in TcRnTypes
 
 getInitialKinds (L _ decl)
-  = do         { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
-       ; res_kind  <- mk_res_kind decl
+  = do         { arg_kinds <- mapM (\_ -> newMetaKindVar) (tyClDeclTyVars decl)
+       ; res_kind  <- get_res_kind decl
         ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind))
        ; inner_pairs <- get_inner_kinds decl
        ; return (main_pair : inner_pairs) }
   where
-    mk_arg_kind (UserTyVar _ _)        = newMetaKindVar
-    mk_arg_kind (KindedTyVar _ kind _) = scDsLHsKind kind
-
-    mk_res_kind (TyFamily { tcdKind    = Just kind }) = scDsLHsKind kind
-    mk_res_kind (TyData   { tcdKindSig = Just kind }) = scDsLHsKind kind
-       -- On GADT-style declarations we allow a kind signature
-       --      data T :: *->* where { ... }
-    mk_res_kind (ClassDecl {}) = return constraintKind
-    mk_res_kind _              = return liftedTypeKind
-
     get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)]
     get_inner_kinds (TyData { tcdCons = cons })
        = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ]
@@ -334,14 +324,13 @@ getInitialKinds (L _ decl)
     get_inner_kinds _
        = return []
 
-kcLookupKind :: Located Name -> TcM Kind
-kcLookupKind nm = do
-    tc_ty_thing <- tcLookupLocated nm
-    case tc_ty_thing of
-        AThing k            -> return k
-        AGlobal (ATyCon tc) -> return (tyConKind tc)
-        _                   -> pprPanic "kcLookupKind" (ppr tc_ty_thing)
-
+    get_res_kind (ClassDecl {})                    = return constraintKind
+    get_res_kind (TyData { tcdKindSig = Nothing }) = return liftedTypeKind
+    get_res_kind _                                 = newMetaKindVar
+            -- Warning: you might be tempted to return * for all data decls
+           -- but on GADT-style declarations we allow a kind signature
+           --   data T :: *->* where { ... }
+            -- with *no tyClDeclTyVars*
 
 ----------------
 kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings
@@ -359,140 +348,94 @@ kcSynDecl1 (CyclicSCC decls)       = do { recSynErr decls; failM }
                                     -- of out-of-scope tycons
 
 kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind)
-kcSynDecl decl       -- Vanilla type synonyoms only, not family instances
+kcSynDecl decl@(TySynonym { tcdTyVars = hs_tvs, tcdLName = L _ name
+                          , tcdSynRhs = rhs })
+  -- Vanilla type synonyoms only, not family instances
+  -- Returns a possibly-unzonked kind
   = tcAddDeclCtxt decl $
-    kcHsTyVars (tcdTyVars decl) $ \ k_tvs ->
-    do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
-                       <+> brackets (ppr k_tvs))
-       ; (_, rhs_kind) <- kcLHsType (tcdSynRhs decl)
-       ; traceTc "kcd2" (ppr (tcdName decl))
-       ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
-       ; return (tcdName decl, tc_kind) }
+    tcHsTyVarBndrs (tcdTyVars decl) $ \ k_tvs ->
+    do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)
+                        <+> brackets (ppr k_tvs))
+       ; (_, rhs_kind) <- tcLHsType rhs
+       ; traceTc "kcd2" (ppr name)
+       ; let tc_kind = foldr (mkArrowKind . tyVarKind) rhs_kind k_tvs
+       ; return (name, tc_kind) }
+kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
 
 ------------------------------------------------------------------------
+kcLTyClDecl :: LTyClDecl Name -> TcM ()
+kcLTyClDecl (L loc decl)
+  = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl
+
 kcTyClDecl :: TyClDecl Name -> TcM ()
 -- This function is used solely for its side effect on kind variables
 
-kcTyClDecl (ForeignType {})   
-  = return ()
-kcTyClDecl decl@(TyFamily {}) 
-  = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl
-
-kcTyClDecl decl@(TyData {})
+kcTyClDecl decl@(TyData { tcdLName = L _ name, tcdTyVars = hs_tvs })
   = ASSERT2( not . isFamInstDecl $ decl, ppr decl )   -- must not be a family instance
-    kcTyClDeclBody decl        $ \_ -> kcDataDecl decl
-
-kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
-  = kcTyClDeclBody decl        $ \ tvs' ->
-    do { discardResult (kcHsContext ctxt)
-       ; mapM_ (wrapLocM (kcFamilyDecl tvs')) ats
-       ; mapM_ (wrapLocM kc_sig) sigs }
+    kcTyClTyVars name hs_tvs $ \ res_k -> kcDataDecl decl res_k
+
+kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
+                       , tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
+  = kcTyClTyVars name hs_tvs $ \ res_k -> 
+    do { _ <- tcHsContext ctxt
+        ; _ <- unifyKind res_k constraintKind
+       ; mapM_ (wrapLocM kcFamilyDecl) ats
+       ; mapM_ (wrapLocM kc_sig)       sigs }
   where
-    kc_sig (TypeSig _ op_ty)    = discardResult (kcHsLiftedSigType op_ty)
-    kc_sig (GenericSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty)
+    kc_sig (TypeSig _ op_ty)    = discardResult (tcHsLiftedType op_ty)
+    kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
     kc_sig _                    = return ()
 
-kcTyClDecl (TySynonym {})     -- Type synonyms are never passed to kcTyClDecl
-  = panic "kcTyClDecl TySynonym"
-
---------------------
-kcTyClDeclBody :: TyClDecl Name
-              -> ([LHsTyVarBndr Name] -> TcM a)
-              -> TcM a
--- getInitialKind has made a suitably-shaped kind for the type or class
--- Unpack it, and attribute those kinds to the type variables
--- Extend the env with bindings for the tyvars, taken from
--- the kind of the tycon/class.  Give it to the thing inside, and 
--- check the result kind matches
-kcTyClDeclBody decl thing_inside
-  = tcAddDeclCtxt decl         $
-    do         { tc_kind <- kcLookupKind (tcdLName de