Refactor LHsTyVarBndrs to fix Trac #6081
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 11 May 2012 17:02:18 +0000 (18:02 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 11 May 2012 17:02:31 +0000 (18:02 +0100)
This is really a small change, but it touches a lot of files quite
significantly. The real goal is to put the implicitly-bound kind
variables of a data/class decl in the right place, namely on the
LHsTyVarBndrs type, which now looks like

  data LHsTyVarBndrs name
    = HsQTvs { hsq_kvs :: [Name]
             , hsq_tvs :: [LHsTyVarBndr name]
      }

This little change made the type checker neater in a number of
ways, but it was fiddly to push through the changes.

19 files changed:
compiler/deSugar/DsMeta.hs
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/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcEvidence.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcTyClsDecls.lhs

index 060b63d..98aec5f 100644 (file)
@@ -150,7 +150,8 @@ repTopDs group
 hsSigTvBinders :: HsValBinds Name -> [Name]
 -- See Note [Scoped type variables in bindings]
 hsSigTvBinders binds
-  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit tvs _ _))) <- sigs, tv <- tvs]
+  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
+                     , tv <- hsQTvBndrs qtvs]
   where
     sigs = case binds of
             ValBindsIn  _ sigs -> sigs
@@ -214,9 +215,8 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour,
            do { flav   <- repFamilyFlavour flavour
              ; case opt_kind of 
                   Nothing -> repFamilyNoKind flav tc1 bndrs
-                  Just (HsBSig ki _) 
-                    -> do { ki1 <- repKind ki 
-                          ; repFamilyKind flav tc1 bndrs ki1 }
+                  Just ki -> do { ki1 <- repKind ki 
+                                ; repFamilyKind flav tc1 bndrs ki1 }
               }
        ; return $ Just (loc, dec)
        }
@@ -272,15 +272,15 @@ repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
        ; repTySyn tc bndrs opt_tys ty1 }
 
 -------------------------
-mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name] 
-             -> HsTyDefn Name -> DsM [LHsTyVarBndr Name]
+mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name 
+             -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
 -- If there is a kind signature it must be of form
 --    k1 -> .. -> kn -> *
 -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
 mk_extra_tvs tc tvs defn
-  | TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn
+  | TyData { td_kindSig = Just hs_kind } <- defn
   = do { extra_tvs <- go hs_kind
-       ; return (tvs ++ extra_tvs) }
+       ; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) }
   | otherwise
   = return tvs
   where
@@ -289,7 +289,7 @@ mk_extra_tvs tc tvs defn
       = do { uniq <- newUnique
            ; let { occ = mkTyVarOccFS (fsLit "t")
                  ; nm = mkInternalName uniq occ loc
-                 ; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) }
+                 ; hs_tv = L loc (KindedTyVar nm kind) }
            ; hs_tvs <- go rest
            ; return (hs_tv : hs_tvs) }
 
@@ -340,7 +340,7 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
            -- the selector Ids, not to fresh names (Trac #5410)
            --
             do { cxt1 <- repContext cxt
-               ; cls_tcon <- repTy (HsTyVar cls)
+               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
                ; cls_tys <- repLTys tys
                ; inst_ty1 <- repTapps cls_tcon cls_tys
                ; binds1 <- rep_binds binds
@@ -350,17 +350,17 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
                ; repInst cxt1 inst_ty1 decls }
        ; return (loc, dec) }
  where
-   Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
+   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
 
 repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
 repFamInstD (FamInstDecl { fid_tycon = tc_name
-                         , fid_pats = HsBSig tys (kv_names, tv_names)
+                         , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
                          , fid_defn = defn })
   = WARN( not (null kv_names), ppr kv_names )   -- We have not yet dealt with kind 
                                                 -- polymorphism in Template Haskell (sigh)
     do { tc <- lookupLOcc tc_name              -- See note [Binders and occurrences]  
        ; let loc = getLoc tc_name
-             hs_tvs = [ L loc (UserTyVar n) | n <- tv_names]   -- Yuk
+             hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names)   -- Yuk
        ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
          do { tys1 <- repLTys tys
             ; tys2 <- coreList typeQTyConName tys1
@@ -419,8 +419,9 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
-repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
+repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
                        , con_details = details, con_res = ResTyH98 }))
+  | null (hsQTvBndrs con_tvs)
   = do { con1 <- lookupLOcc con        -- See note [Binders and occurrences] 
        ; repConstr con1 details  }
 repC tvs (L _ (ConDecl { con_name = con
@@ -428,7 +429,7 @@ repC tvs (L _ (ConDecl { con_name = con
                        , con_details = details
                        , con_res = res_ty }))
   = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
-       ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
+       ; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
        ; binds <- mapM dupBinder con_tv_subst 
        ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
          addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
@@ -552,7 +553,7 @@ rep_ty_sig loc (L _ ty) nm
     rep_ty (HsForAllTy Explicit tvs ctxt ty)
       = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                          ; repTyVarBndrWithKind tv name }
-           ; bndrs1 <- mapM rep_in_scope_tv tvs
+           ; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs)
            ; bndrs2 <- coreList tyVarBndrTyConName bndrs1
            ; ctxt1  <- repLContext ctxt
            ; ty1    <- repLTy ty
@@ -616,7 +617,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin
 --                     Types
 -------------------------------------------------------
 
-addTyVarBinds :: [LHsTyVarBndr Name]                          -- the binders to be added
+addTyVarBinds :: LHsTyVarBndrs Name                           -- the binders to be added
               -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
               -> DsM (Core (TH.Q a))
 -- gensym a list of type variables and enter them into the meta environment;
@@ -626,14 +627,14 @@ addTyVarBinds :: [LHsTyVarBndr Name]                             -- the binders to be
 addTyVarBinds tvs m
   = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
        ; term <- addBinds freshNames $ 
-                do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames)
+                do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
                     ; kbs2 <- coreList tyVarBndrTyConName kbs1
                    ; m kbs2 }
        ; wrapGenSyms freshNames term }
   where
     mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
 
-addTyClTyVarBinds :: [LHsTyVarBndr Name]
+addTyClTyVarBinds :: LHsTyVarBndrs Name
                   -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                   -> DsM (Core (TH.Q a))
 
@@ -650,7 +651,7 @@ addTyClTyVarBinds tvs m
             -- This makes things work for family declarations
 
        ; term <- addBinds freshNames $ 
-                do { kbs1 <- mapM mk_tv_bndr tvs
+                do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs)
                     ; kbs2 <- coreList tyVarBndrTyConName kbs1
                    ; m kbs2 }
 
@@ -665,7 +666,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
   = repKind ki >>= repKindedTV nm
 
 -- represent a type context
index 7e8ceb6..8d5ad6b 100644 (file)
@@ -275,7 +275,7 @@ cvt_ci_decs doc decs
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
              -> CvtM ( LHsContext RdrName
                      , Located RdrName
-                     , [LHsTyVarBndr RdrName])
+                     , LHsTyVarBndrs RdrName)
 cvt_tycl_hdr cxt tc tvs
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
@@ -286,12 +286,12 @@ cvt_tycl_hdr cxt tc tvs
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
                -> CvtM ( LHsContext RdrName
                        , Located RdrName
-                       , HsBndrSig [LHsType RdrName])
+                       , HsWithBndrs [LHsType RdrName])
 cvt_tyinst_hdr cxt tc tys
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tys' <- mapM cvtType tys
-       ; return (cxt', tc', mkHsBSig tys') }
+       ; return (cxt', tc', mkHsWithBndrs tys') }
 
 -------------------------------------------------------------------
 --             Partitioning declarations
@@ -348,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con)
   = do { tvs'  <- cvtTvs tvs
        ; L loc ctxt' <- cvtContext ctxt
        ; L _ con' <- cvtConstr con
-       ; returnL $ con' { con_qvars = tvs' ++ con_qvars con'
+       ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
                          , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
@@ -759,7 +759,7 @@ cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
                            ; 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' (mkHsBSig t') }
+                            ; return $ SigPatIn p' (mkHsWithBndrs t') }
 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))
@@ -784,8 +784,8 @@ cvtOpAppP x op y
 -----------------------------------------------------------
 --     Types and type variables
 
-cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
-cvtTvs tvs = mapM cvt_tv tvs
+cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm) 
@@ -794,7 +794,7 @@ cvt_tv (TH.PlainTV nm)
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' (mkHsBSig ki') }
+       ; returnL $ KindedTyVar nm' ki' }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
@@ -845,7 +845,7 @@ cvtType ty
              -> do { tvs' <- cvtTvs tvs
                    ; cxt' <- cvtContext cxt
                    ; ty'  <- cvtType ty
-                   ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' 
+                   ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' 
                    }
 
            SigT ty ki
@@ -875,10 +875,10 @@ cvtKind (ArrowK k1 k2) = do
   k2' <- cvtKind k2
   returnL (HsFunTy k1' k2')
 
-cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
+cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
 cvtMaybeKind Nothing = return Nothing
 cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
-                            ; return (Just (mkHsBSig ki')) }
+                            ; return (Just ki') }
 
 -----------------------------------------------------------
 cvtFixity :: TH.Fixity -> Hs.Fixity
index c789a9e..cf1c2c9 100644 (file)
@@ -428,20 +428,20 @@ data TyClDecl name
   | -- | @type/data family T :: *->*@
     TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
                 tcdLName   :: Located name,              -- type constructor
-                tcdTyVars  :: [LHsTyVarBndr name],       -- type variables
-                tcdKindSig :: Maybe (HsBndrSig (LHsKind name))  -- result kind
+                tcdTyVars  :: LHsTyVarBndrs name,        -- type variables
+                tcdKindSig :: Maybe (LHsKind name)       -- result kind
     }
 
 
   | -- | @type/data declaration
     TyDecl { tcdLName  :: Located name            -- ^ Type constructor
-           , tcdTyVars :: [LHsTyVarBndr name]
+           , tcdTyVars :: LHsTyVarBndrs name
            , tcdTyDefn :: HsTyDefn name
            , tcdFVs    :: NameSet }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
-                tcdTyVars  :: [LHsTyVarBndr name],      -- ^ Class type variables
+                tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
@@ -468,7 +468,7 @@ data HsTyDefn name   -- The payload of a type synonym or data type defn
     TyData { td_ND     :: NewOrData,
              td_ctxt   :: LHsContext name,           -- ^ Context
              td_cType  :: Maybe CType,
-             td_kindSig:: Maybe (HsBndrSig (LHsKind name)),
+             td_kindSig:: Maybe (LHsKind name),
                      -- ^ Optional kind signature.
                      --
                      -- @(Just k)@ for a GADT-style @data@, or @data
@@ -619,18 +619,18 @@ instance OutputableBndr name
 
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
-   -> [LHsTyVarBndr name]
+   -> LHsTyVarBndrs name
    -> HsContext name
    -> SDoc
 pp_vanilla_decl_head thing tyvars context
- = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars]
+ = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
 
 pp_fam_inst_head :: OutputableBndr name
    => Located name
-   -> HsBndrSig [LHsType name]
+   -> HsWithBndrs [LHsType name]
    -> HsContext name
    -> SDoc
-pp_fam_inst_head thing (HsBSig typats _)  context -- explicit type patterns
+pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
    = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
           , hsep (map (pprParendHsType.unLoc) typats)]
 
@@ -660,8 +660,8 @@ pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
        2 (pp_condecls condecls $$ pp_derivings)
   where
     pp_sig = case mb_sig of
-               Nothing              -> empty
-               Just (HsBSig kind _) -> dcolon <+> ppr kind
+               Nothing   -> empty
+               Just kind -> dcolon <+> ppr kind
     pp_derivings = case derivings of
                      Nothing -> empty
                      Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
@@ -715,7 +715,7 @@ data ConDecl name
     , con_explicit  :: HsExplicitFlag
         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
-    , con_qvars     :: [LHsTyVarBndr name]
+    , con_qvars     :: LHsTyVarBndrs name
         -- ^ Type variables.  Depending on 'con_res' this describes the
         -- following entities
         --
@@ -808,8 +808,8 @@ type LFamInstDecl name = Located (FamInstDecl name)
 data FamInstDecl name 
   = FamInstDecl
        { fid_tycon :: Located name
-       , fid_pats  :: HsBndrSig [LHsType name]  -- ^ Type patterns (with bndrs)
-       , fid_defn  :: HsTyDefn name             -- Type or data family instance
+       , fid_pats  :: HsWithBndrs [LHsType name]  -- ^ Type patterns (with kind and type bndrs)
+       , fid_defn  :: HsTyDefn name               -- Type or data family instance
        , fid_fvs   :: NameSet  } 
   deriving( Typeable, Data )
 
@@ -1060,10 +1060,10 @@ data RuleDecl name
 
 data RuleBndr name
   = RuleBndr (Located name)
-  | RuleBndrSig (Located name) (HsBndrSig (LHsType name))
+  | RuleBndrSig (Located name) (HsWithBndrs (LHsType name))
   deriving (Data, Typeable)
 
-collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)]
+collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
index 1a5e206..64bda89 100644 (file)
@@ -131,8 +131,8 @@ data Pat id
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
 
         ------------ Pattern type signatures ---------------
-  | SigPatIn        (LPat id)           -- Pattern with a type signature
-                    (HsBndrSig (LHsType id))
+  | SigPatIn        (LPat id)                   -- Pattern with a type signature
+                    (HsWithBndrs (LHsType id))  -- Signature can bind both kind and type vars
 
   | SigPatOut       (LPat id)           -- Pattern with a type signature
                     Type
index 9a6679a..2504ad8 100644 (file)
@@ -17,7 +17,9 @@ HsTypes: Abstract syntax: user-defined types
 
 module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
-        HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
+        HsTyVarBndr(..), LHsTyVarBndr, 
+        LHsTyVarBndrs(..),
+        HsWithBndrs(..),
         HsTupleSort(..), HsExplicitFlag(..),
         HsContext, LHsContext,
         HsQuasiQuote(..),
@@ -29,15 +31,14 @@ module HsTypes (
 
         ConDeclField(..), pprConDeclFields,
         
+        mkHsQTvs, hsQTvBndrs,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-        hsTyVarName, hsTyVarNames, 
+        hsTyVarName, hsTyVarNames, mkHsWithBndrs,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
-        splitHsForAllTy, splitLHsForAllTy,
+        splitLHsInstDeclTy_maybe,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
         splitHsAppTys, mkHsAppTys, mkHsOpTy,
-        placeHolderBndrs,
 
         -- Printing
         pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
@@ -112,6 +113,17 @@ getBangStrictness _                    = HsNoBang
 
 This is the syntax for types as seen in type signatures.
 
+Note [HsBSig binder lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+See also Note [Kind and type-variable binders] in RnTypes
+
 \begin{code}
 type LHsContext name = Located (HsContext name)
 
@@ -123,29 +135,29 @@ type LHsKind name = Located (HsKind name)
 
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
-data HsBndrSig sig 
-  = HsBSig 
-       sig                -- The signature; typically a type
-       ([Name], [Name])   -- The *binding* (kind, type) names of 
-                          -- this signature
-                          -- See Note [HsBSig binder lists]
-                          
+data LHsTyVarBndrs name 
+  = HsQTvs { hsq_kvs :: [Name]                  -- Kind variables
+           , hsq_tvs :: [LHsTyVarBndr name]     -- Type variables
+             -- See Note [HsForAllTy tyvar binders]
+    }
+  deriving( Data, Typeable )
+
+mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name
+mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs }
+
+hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
+hsQTvBndrs = hsq_tvs
+
+data HsWithBndrs thing
+  = HsWB { hswb_cts :: thing           -- Main payload (type or list of types)
+         , hswb_kvs :: [Name]         -- Kind vars
+         , hswb_tvs :: [Name]        -- Type vars
+    }                  
   deriving (Data, Typeable)
 
--- Note [HsBSig binder lists]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- 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
--- See also Note [Kind and type-variable binders] in RnTypes
-
-placeHolderBndrs :: [Name]
--- Used for the NameSet in FunBind and PatBind prior to the renamer
-placeHolderBndrs = panic "placeHolderBndrs"
+mkHsWithBndrs :: thing -> HsWithBndrs thing
+mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
+                                     , hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
 
 data HsTyVarBndr name
   = UserTyVar           -- No explicit kinding
@@ -153,17 +165,18 @@ data HsTyVarBndr name
 
   | KindedTyVar
          name
-         (HsBndrSig (LHsKind name))   -- The user-supplied kind signature
+         (LHsKind name)   -- The user-supplied kind signature
       --  *** 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]     -- See Note [HsForAllTy tyvar binders]
+                (LHsTyVarBndrs name) 
                 (LHsContext name)
                 (LHsType name)
 
@@ -252,11 +265,11 @@ 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.
+The kind variables bound in the hsq_kvs field come both
+  a) from the kind signatures on the kind vars (eg k1)
+  b) from the scope of the forall (eg k2)
+Example:   f :: forall (a::k1) b. T a (b::k2)
+
 
 Note [Unit tuples]
 ~~~~~~~~~~~~~~~~~~
@@ -357,19 +370,19 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
 
 mkImplicitHsForAllTy ::                        LHsContext name -> LHsType name -> HsType name
 mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
-mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit [] ctxt ty
+mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit []  ctxt ty
 mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
 
 mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
 -- Smart constructor for HsForAllTy
 mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
-mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
+mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
-mk_forall_ty exp  tvs  (L _ (HsParTy ty))                   = mk_forall_ty exp tvs ty
-mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty                                   = HsForAllTy exp tvs (noLoc []) ty
+mk_forall_ty exp  tvs  (L _ (HsParTy ty))                    = mk_forall_ty exp tvs ty
+mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
+mk_forall_ty exp  tvs  ty                                    = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty
         -- Even if tvs is empty, we still make a HsForAll!
         -- In the Implicit case, this signals the place to do implicit quantification
         -- In the Explicit case, it prevents implicit quantification    
@@ -396,14 +409,14 @@ hsLTyVarName = hsTyVarName . unLoc
 hsTyVarNames :: [HsTyVarBndr name] -> [name]
 hsTyVarNames tvs = map hsTyVarName tvs
 
-hsLTyVarNames :: [LHsTyVarBndr name] -> [name]
-hsLTyVarNames = map hsLTyVarName
+hsLTyVarNames :: LHsTyVarBndrs name -> [name]
+hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
 
 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
 hsLTyVarLocName = fmap hsTyVarName
 
-hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
-hsLTyVarLocNames = map hsLTyVarLocName
+hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
+hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
 \end{code}
 
 
@@ -421,31 +434,23 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
        -- Add noLocs for inner nodes of the application; 
        -- they are never used 
 
-splitHsInstDeclTy_maybe :: HsType name 
-                        -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
-splitHsInstDeclTy_maybe ty
-  = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty)
-
 splitLHsInstDeclTy_maybe
     :: LHsType name 
-    -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
+    -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name])
         -- Split up an instance decl type, returning the pieces
 splitLHsInstDeclTy_maybe inst_ty = do
     let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
     (cls, tys) <- splitLHsClassTy_maybe ty
     return (tvs, cxt, cls, tys)
 
-splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name)
-splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty)
-
 splitLHsForAllTy
     :: LHsType name 
-    -> ([LHsTyVarBndr name], HsContext name, LHsType name)
+    -> (LHsTyVarBndrs name, HsContext name, LHsType name)
 splitLHsForAllTy poly_ty
   = case unLoc poly_ty of
         HsParTy ty              -> splitLHsForAllTy ty
         HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                       -> ([], [], poly_ty)
+        _                       -> (mkHsQTvs [], [], poly_ty)
         -- The type vars should have been computed by now, even if they were implicit
 
 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
@@ -494,22 +499,25 @@ instance (OutputableBndr name) => Outputable (HsType name) where
 instance Outputable HsTyLit where
     ppr = ppr_tylit
 
-instance (Outputable sig) => Outputable (HsBndrSig sig) where
-    ppr (HsBSig ty _) = ppr ty
+instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
+    ppr qtvs = interppSP (hsQTvBndrs qtvs)
 
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name)        = ppr name
     ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind]
 
-pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
-pprHsForAll exp tvs cxt 
+instance (Outputable thing) => Outputable (HsWithBndrs thing) where
+    ppr (HsWB { hswb_cts = ty }) = ppr ty
+
+pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name ->  LHsContext name -> SDoc
+pprHsForAll exp qtvs cxt 
   | show_forall = forall_part <+> pprHsContext (unLoc cxt)
   | otherwise   = pprHsContext (unLoc cxt)
   where
     show_forall =  opt_PprStyle_Debug
-                || (not (null tvs) && is_explicit)
+                || (not (null (hsQTvBndrs qtvs)) && is_explicit)
     is_explicit = case exp of {Explicit -> True; Implicit -> False}
-    forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
+    forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []         = empty
index 8ac0476..32fe487 100644 (file)
@@ -33,7 +33,7 @@ module HsUtils(
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
-  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig, 
+  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, 
 
   -- Bindings
   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
@@ -265,9 +265,6 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 mkHsString :: String -> HsLit
 mkHsString s = HsString (mkFastString s)
 
-mkHsBSig :: a -> HsBndrSig a
-mkHsBSig x = HsBSig x (placeHolderBndrs, placeHolderBndrs)
-
 -------------
 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
 -- Caller sets location
index a9cb1d3..759d544 100644 (file)
@@ -728,9 +728,9 @@ data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
         | 'newtype'     { L1 NewType }
 
-opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
+opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
         :                               { noLoc Nothing }
-        | '::' kind                     { LL (Just (mkHsBSig $2)) }
+        | '::' kind                     { LL (Just $2) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -877,7 +877,7 @@ rule_var_list :: { [RuleBndr RdrName] }
 
 rule_var :: { RuleBndr RdrName }
         : varid                                 { RuleBndr $1 }
-        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (mkHsBSig $4) }
+        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (mkHsWithBndrs $4) }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
@@ -1113,7 +1113,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { L1 (UserTyVar (unLoc $1)) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (mkHsBSig $4)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
index eee8831..0382fca 100644 (file)
@@ -128,14 +128,14 @@ tdefs     :: { [TyClDecl RdrName] }
 tdef   :: { TyClDecl RdrName }
        : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
        { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
-                 , tcdTyVars = map toHsTvBndr $3
+                 , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
                  , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc [] 
                                      , td_kindSig = Nothing
                                       , td_cons = $6, td_derivs = Nothing } } }
        | '%newtype' q_tc_name tv_bndrs trep ';'
        { let tc_rdr = ifaceExtRdrName $2 in
           TyDecl { tcdLName = noLoc tc_rdr
-                , tcdTyVars = map toHsTvBndr $3
+                , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
                  , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
                                      , td_kindSig = Nothing
                                       , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } }
@@ -377,16 +377,16 @@ ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
                   where
-                    bsig = mkHsBSig (toHsKind k)
+                    bsig = toHsKind k
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
 
 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
-  = noLoc $ HsForAllTy exp (tv:tvs) cxt t
+  = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t
 add_forall tv t
-  = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
+  = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t
   
 happyError :: P a 
 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
index 95b65de..350aedb 100644 (file)
@@ -122,7 +122,7 @@ mkTyData :: SrcSpan
          -> NewOrData
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe (HsBndrSig (LHsKind RdrName))
+         -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
@@ -138,20 +138,20 @@ mkFamInstData :: SrcSpan
          -> NewOrData
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe (HsBndrSig (LHsKind RdrName))
+         -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LFamInstDecl RdrName)
 mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
+       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
                                     , fid_defn = defn, fid_fvs = placeHolderNames })) }
 
 mkDataDefn :: NewOrData
            -> Maybe CType
            -> Maybe (LHsContext RdrName)
-           -> Maybe (HsBndrSig (LHsKind RdrName))
+           -> Maybe (LHsKind RdrName)
            -> [LConDecl RdrName]
            -> Maybe [LHsType RdrName]
            -> P (HsTyDefn RdrName)
@@ -181,14 +181,14 @@ mkFamInstSynonym :: SrcSpan
             -> P (LFamInstDecl RdrName)
 mkFamInstSynonym loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
-       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
+       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
                                     , fid_defn = TySynonym { td_synRhs = rhs }
                                     , fid_fvs = placeHolderNames })) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
            -> LHsType RdrName   -- LHS
-           -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature
+           -> Maybe (LHsKind RdrName) -- Optional kind signature
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
@@ -367,7 +367,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
        ; return (L loc (ConDecl { con_old_rec  = True
                                 , con_name     = data_con
                                 , con_explicit = Implicit
-                                , con_qvars    = []
+                                , con_qvars    = mkHsQTvs []
                                 , con_cxt      = noLoc []
                                 , con_details  = RecCon flds
                                 , con_res      = ResTyGADT res_ty
@@ -381,7 +381,7 @@ mkSimpleConDecl name qvars cxt details
   = ConDecl { con_old_rec  = False
             , con_name     = name
             , con_explicit = Explicit
-            , con_qvars    = qvars
+            , con_qvars    = mkHsQTvs qvars
             , con_cxt      = cxt
             , con_details  = details
             , con_res      = ResTyH98
@@ -444,17 +444,18 @@ we can bring x,y into scope.  So:
    * For RecCon we do not
 
 \begin{code}
-checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
 -- non-variable; otherwise, we allow non-variable arguments and return the
 -- entire list of parameters.
-checkTyVars tycl_hdr tparms = mapM chk tparms
+checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms
+                                 ; return (mkHsQTvs tvs) }
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv (mkHsBSig k)))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L l _)
@@ -579,7 +580,7 @@ checkAPat dynflags loc e0 = case e0 of
                             let t' = case t of
                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
                                        other -> other
-                            return (SigPatIn e (mkHsBSig t'))
+                            return (SigPatIn e (mkHsWithBndrs t'))
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
index a8f882a..79ccb21 100644 (file)
@@ -539,7 +539,7 @@ mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
     env :: NameEnv [Name]
-    env = mkNameEnv [ (name, map hsLTyVarName ltvs)
+    env = mkNameEnv [ (name, hsLTyVarNames ltvs)
                    | L _ (TypeSig names
                                   (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
                     , (L _ name) <- names]
index 9cb04ff..b1f393b 100644 (file)
@@ -36,7 +36,7 @@ module RnEnv (
        bindLocatedLocalsFV, bindLocatedLocalsRn,
        extendTyVarEnvFVRn,
 
-       checkDupRdrNames, checkDupAndShadowedRdrNames,
+       checkDupRdrNames, checkShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, 
        addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
        warnUnusedMatches,
@@ -1185,7 +1185,8 @@ bindLocatedLocalsRn :: [Located RdrName]
                    -> ([Name] -> RnM a)
                    -> RnM a
 bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
-  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
+  = do { checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
 
        -- Make fresh Names and extend the environment
        ; names <- newLocalBndrsRn rdr_names_w_loc
@@ -1243,11 +1244,10 @@ checkDupNames names
                -- See Note [Binders in Template Haskell] in Convert
 
 ---------------------
-checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM ()
-checkDupAndShadowedRdrNames loc_rdr_names
-  = do { checkDupRdrNames loc_rdr_names
-       ; envs <- getRdrEnvs
-       ; checkShadowedOccs envs loc_occs }
+checkShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkShadowedRdrNames loc_rdr_names
+  = do { envs <- getRdrEnvs
+       ; checkShadowedOccs envs loc_occs }
   where
     loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names]
 
@@ -1645,8 +1645,10 @@ data HsDocContext
   | SpliceTypeCtx (LHsType RdrName)
   | ClassInstanceCtx
   | VectDeclCtx (Located RdrName)
+  | GenericCtx SDoc   -- Maybe we want to use this more!
 
 docOfHsDocContext :: HsDocContext -> SDoc
+docOfHsDocContext (GenericCtx doc) = doc
 docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
 docOfHsDocContext PatCtx = text "In a pattern type-signature"
 docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
@@ -1666,5 +1668,4 @@ docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
 docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
 docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
 docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
-
 \end{code}
index d0302a1..3e3c2b6 100644 (file)
@@ -162,9 +162,9 @@ matchNameMaker ctxt = LamMk report_unused
                       StmtCtxt GhciStmt -> False
                       _                 -> True
 
-rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name))
+rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name))
 rnHsSigCps sig 
-  = CpsRn (rnHsBndrSig True PatCtx sig)
+  = CpsRn (rnHsBndrSig PatCtx sig)
 
 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
 newPatName (LamMk report_unused) rdr_name
index 8c338c8..9509b0a 100644 (file)
@@ -43,7 +43,6 @@ import Outputable
 import Bag
 import BasicTypes       ( RuleName )
 import FastString
-import Util            ( filterOut )
 import SrcLoc
 import DynFlags
 import HscTypes                ( HscEnv, hsc_dflags )
@@ -485,7 +484,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
             --     to remove the context).
 
 rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
-rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn })
+rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
+                                  ,  fid_pats = HsWB { hswb_cts = pats }
+                                  , fid_defn = defn })
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -494,8 +495,9 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
              (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
 
 
-       ; kv_names <- mkTyVarBndrNames mb_cls (map (L loc) kv_rdr_names)
-       ; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) tv_rdr_names)
+       ; rdr_env  <- getLocalRdrEnv
+       ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
+       ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
                     -- All the free vars of the family patterns
              -- with a sensible binding location
        ; ((pats', defn'), fvs) 
@@ -516,8 +518,8 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
        ; return ( FamInstDecl { fid_tycon = tycon'
-                              , fid_pats = HsBSig pats' (kv_names, tv_names)
-                              , fid_defn = defn', fid_fvs = all_fvs }
+                              , fid_pats  = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
+                              , fid_defn  = defn', fid_fvs = all_fvs }
                 , all_fvs ) }
                     -- type instance => use, hence addOneFV
 \end{code}
@@ -543,13 +545,13 @@ For the method bindings in class and instance decls, we extend the
 type variable environment iff -fglasgow-exts
 
 \begin{code}
-extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
+extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name
                              -> RnM (Bag (LHsBind Name), FreeVars)
                              -> RnM (Bag (LHsBind Name), FreeVars)
 extendTyVarEnvForMethodBinds tyvars thing_inside
   = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
        ; if scoped_tvs then
-               extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+               extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside
          else
                thing_inside }
 \end{code}
@@ -584,7 +586,8 @@ standaloneDerivErr
 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
   = do { let rdr_names_w_loc = map get_var vars
-       ; checkDupAndShadowedRdrNames rdr_names_w_loc
+       ; checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
        ; bindHsRuleVars rule_name vars names $ \ vars' -> 
     do { (lhs', fv_lhs') <- rnLExpr lhs
@@ -610,7 +613,7 @@ bindHsRuleVars rule_name vars names thing_inside
         thing_inside (RuleBndr (L loc n) : vars')
 
     go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
-      = rnHsBndrSig True doc bsig $ \ bsig' ->
+      = rnHsBndrSig doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
         thing_inside (RuleBndrSig (L loc n) bsig' : vars')
 
@@ -841,38 +844,40 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
                             , tcdFlavour = flav, tcdKindSig = kind })
-  = do { let tv_rdr_names = hsLTyVarLocNames tyvars
-       ; checkDupRdrNames tv_rdr_names     -- Check for duplicated bindings
-       ; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names
-       ; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' ->
+  = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
        ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
                            , tcdFlavour = flav, tcdKindSig = kind' }
-                , fv_kind) } }
+                , fv_kind ) }
   where 
      fmly_doc = TyFamilyCtx tycon
+     kvs = extractRdrKindSigVars kind
 
 -- "data", "newtype" declarations
 -- both top level and (for an associated type) in an instance decl
-rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' ->
+       ; let kvs = extractTyDefnKindVars defn
+       ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
+       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' ->
                                     do { (defn', fvs) <- rnTyDefn tycon defn
                                        ; return ((tyvars', defn'), fvs) }
        ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
                         , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
 
-rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
-                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
-                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
-                         tcdDocs = docs})
+rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
+                             tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+                             tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+                              tcdDocs = docs})
   = do { lcls' <- lookupLocatedTopBndrRn lcls
         ; let cls' = unLoc lcls'
+              kvs = []  -- No scoped kind vars except those in 
+                        -- kind signatures on the tyvars
 
        -- Tyvars scope over superclass context and method signatures
        ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-           <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do
+           <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
                 -- Checks for distinct tyvars
             { (context', cxt_fvs) <- rnContext cls_doc context
             ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
@@ -1043,21 +1048,6 @@ is jolly confusing.  See Trac #4875
 
 \begin{code}
 ---------------
-mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name]
-mkTyVarBndrNames Nothing tv_rdr_names
-  = newLocalBndrsRn tv_rdr_names
-mkTyVarBndrNames (Just _) tv_rdr_names
-  = do { 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)
-
-       ; mapM mk_tv_name tv_rdr_names }
-
----------------
 badAssocRhs :: [Name] -> RnM ()
 badAssocRhs ns
   = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
@@ -1082,22 +1072,21 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
           -- For GADT syntax, the tvs are all the quantified tyvars
           -- Hence the 'filter' in the ResTyH98 case only
         ; rdr_env <- getLocalRdrEnv
-        ; let in_scope tv  = tv `elemLocalRdrEnv` rdr_env
-             arg_tys      = hsConDeclArgTys details
-             mentioned_tvs = case res_ty of
-                              ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
-                              ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+        ; let arg_tys    = hsConDeclArgTys details
+             (free_kvs, free_tvs) = case res_ty of
+                                      ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
+                                      ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 
          -- With an Explicit forall, check for unused binders
         -- With Implicit, find the mentioned ones, and use them as binders
        ; new_tvs <- case expl of
-                      Implicit -> return (userHsTyVarBndrs loc mentioned_tvs)
-                      Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
+                      Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
+                      Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
                                       ; return tvs }
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindHsTyVars doc new_tvs $ \new_tyvars -> do
+        ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
        { (new_context, fvs1) <- rnContext doc lcxt
        ; (new_details, fvs2) <- rnConDeclDetails doc details
         ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
@@ -1106,7 +1095,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
  where
     doc = ConDeclCtx name
-    get_rdr_tvs tys = snd (extractHsTysRdrTyVars (cxt ++ tys))
+    get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
 
 rnConResult :: HsDocContext -> Name
             -> HsConDetails (LHsType Name) [ConDeclField Name]
index 99401fa..1b2e841 100644 (file)
@@ -16,7 +16,7 @@ module RnTypes (
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
        rnHsSigType, rnLHsInstType, rnConDeclFields,
-        rnIPName,
+        rnIPName, newTyVarNameRn,
 
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -26,9 +26,9 @@ module RnTypes (
        rnSplice, checkTH,
 
         -- Binding related stuff
-        bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig,
-        extractHsTyRdrTyVars, extractHsTysRdrTyVars
-
+        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
+        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+        extractRdrKindSigVars, extractTyDefnKindVars, filterInScope
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -54,8 +54,9 @@ import BasicTypes     ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
                          Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
+import Maybes
 import Data.List        ( nub )
-import Control.Monad   ( unless )
+import Control.Monad   ( unless, when )
 
 #include "HsVersions.h"
 \end{code}
@@ -78,7 +79,7 @@ rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 -- Rename the type in an instance or standalone deriving decl
 rnLHsInstType doc_str ty 
-  = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty
+  = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
        ; return (ty', fvs) }
   where
@@ -108,13 +109,13 @@ rnLHsType = rnLHsTyKi True
 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
 rnLHsKind = rnLHsTyKi False
 
-rnLHsMaybeKind  :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
-                -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
+rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
+                -> RnM (Maybe (LHsKind Name), FreeVars)
 rnLHsMaybeKind _ Nothing 
   = return (Nothing, emptyFVs)
-rnLHsMaybeKind doc (Just bsig
-  = rnHsBndrSig False doc bsig $ \ bsig' -> 
-    return (Just bsig', emptyFVs)
+rnLHsMaybeKind doc (Just kind
+  = do { (kind', fvs) <- rnLHsKind doc kind
+       ; return (Just kind', fvs) }
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsType = rnHsTyKi True
@@ -128,33 +129,33 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
-    name_env <- getLocalRdrEnv
+    rdr_env <- getLocalRdrEnv
     loc <- getSrcSpanM
     let
-       (_kvs, mentioned) = extractHsTysRdrTyVars (ty:ctxt)
+       (forall_kvs, forall_tvs) = filterInScope rdr_env $
+                                   extractHsTysRdrTyVars (ty:ctxt)
            -- In for-all types we don't bring in scope
            -- kind variables mentioned in kind signatures
            -- (Well, not yet anyway....)
            --    f :: Int -> T (a::k)    -- Not allowed
 
-       -- Don't quantify over type variables that are in scope;
-       -- when GlasgowExts is off, there usually won't be any, except for
-       -- class signatures:
-       --      class C a where { op :: a -> a }
-       forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
-       tyvar_bndrs   = userHsTyVarBndrs loc forall_tyvars
+           -- The filterInScope is to ensure that we don't quantify over
+          -- type variables that are in scope; when GlasgowExts is off,
+          -- there usually won't be any, except for class signatures:
+          --   class C a where { op :: a -> a }
+       tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
 
-    rnForAll doc Implicit tyvar_bndrs lctxt ty
+    rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
 
 rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
   = ASSERT ( isType ) do {     -- Explicit quantification.
          -- Check that the forall'd tyvars are actually 
         -- mentioned in the type, and produce a warning if not
-         let (_kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
+         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
        ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
 
-       ; rnForAll doc Explicit forall_tyvars lctxt tau }
+       ; rnForAll doc Explicit kvs forall_tyvars lctxt tau }
 
 rnHsTyKi isType _ (HsTyVar rdr_name)
   = do { name <- rnTyVar isType rdr_name
@@ -310,11 +311,15 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
 
 
 \begin{code}
-rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
+rnForAll :: HsDocContext -> HsExplicitFlag 
+         -> [RdrName]                -- Kind variables
+         -> LHsTyVarBndrs RdrName   -- Type variables
         -> LHsContext RdrName -> LHsType RdrName 
          -> RnM (HsType Name, FreeVars)
 
-rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
+rnForAll doc exp kvs forall_tyvars ctxt ty
+  | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
+  = rnHsType doc (unLoc ty)
        -- One reason for this case is that a type like Int#
        -- starts off as (HsForAllTy Nothing [] Int), in case
        -- there is some quantification.  Now that we have quantified
@@ -323,8 +328,8 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
        -- get an error, because the body of a genuine for-all is
        -- of kind *.
 
-rnForAll doc exp forall_tyvars ctxt ty
-  = bindHsTyVars doc forall_tyvars $ \ new_tyvars ->
+  | otherwise
+  = bindHsTyVars doc Nothing kvs 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) }
@@ -346,51 +351,70 @@ bindSigTyVarsFV tvs thing_inside
                bindLocalNamesFV tvs thing_inside }
 
 ---------------
-bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
-             -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-             -> RnM (a, FreeVars)
-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
-    rdr_names_w_loc = hsLTyVarLocNames tv_bndrs
-
----------------
-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 _) : tvs) (n : ns) thing_inside
-      = go tvs ns $ \ tvs' ->
-        thing_inside (L loc (UserTyVar n) : tvs')
-
-    go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside
-      = rnHsBndrSig False doc bsig $ \ bsig' ->
-        go tvs ns $ \ tvs' ->
-        thing_inside (L loc (KindedTyVar n bsig') : tvs')
+bindHsTyVars :: HsDocContext 
+             -> Maybe a                 -- Just _  => an associated type decl
+             -> [RdrName]               -- Kind variables from scope
+             -> LHsTyVarBndrs RdrName   -- Type variables
+             -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
+             -> RnM (b, FreeVars)
+-- (a) Bring kind variables into scope 
+--     both (i) passed in (kv_bndrs) and (ii) mentioned in the kinds of tv_bndrs
+-- (b) Bring type variables into scope
+bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
+  = do { rdr_env <- getLocalRdrEnv
+       ; let tvs = hsQTvBndrs tv_bndrs
+             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
+                                 , let (_, kvs) = extractHsTyRdrTyVars kind
+                                 , kv <- kvs ]
+             all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
+                       nub (kv_bndrs ++ kvs_from_tv_bndrs)
+       ; poly_kind <- xoptM Opt_PolyKinds
+       ; unless (poly_kind || null all_kvs) 
+                (addErr (badKindBndrs doc all_kvs))
+       ; loc <- getSrcSpanM
+       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
+       ; bindLocalNamesFV kv_names $ 
+    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
+
+            rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
+            rn_tv_bndr (L loc (UserTyVar rdr)) 
+              = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+                   ; return (L loc (UserTyVar nm), emptyFVs) }
+            rn_tv_bndr (L loc (KindedTyVar rdr kind)) 
+              = do { sig_ok <- xoptM Opt_KindSignatures
+                    ; unless sig_ok (badSigErr False doc kind)
+                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+                   ; (kind', fvs) <- rnLHsKind doc kind
+                   ; return (L loc (KindedTyVar nm kind'), fvs) }
+
+       -- Check for duplicate or shadowed tyvar bindrs
+       ; checkDupRdrNames tv_names_w_loc
+       ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
+
+       ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
+       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
+                        do { env <- getLocalRdrEnv
+                           ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
+                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
+       ; return (res, fvs1 `plusFV` fvs2) } }
 
-    -- Lists of unequal length
-    go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
+newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
+newTyVarNameRn mb_assoc rdr_env loc rdr
+  | Just _ <- mb_assoc    -- Use the same Name as the parent class decl
+  , Just n <- lookupLocalRdrEnv rdr_env rdr
+  = return n   
+  | otherwise 
+  = newLocalBndrRn (L loc rdr)
 
 --------------------------------
-rnHsBndrSig :: Bool    -- True <=> type sig, False <=> kind sig
-            -> HsDocContext
-            -> HsBndrSig (LHsType RdrName)
-            -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
+rnHsBndrSig :: HsDocContext
+            -> HsWithBndrs (LHsType RdrName)
+            -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars))
             -> RnM (a, FreeVars)
-rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
-  = do { let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
-       ; checkHsBndrFlags is_type doc ty tv_bndrs 
+rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
+  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
+       ; unless sig_ok (badSigErr True doc ty)
+       ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
        ; name_env <- getLocalRdrEnv
        ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
                                                , not (tv `elemLocalRdrEnv` name_env) ]
@@ -398,26 +422,13 @@ rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
                                                , not (kv `elemLocalRdrEnv` name_env) ]
        ; bindLocalNamesFV kv_names $ 
          bindLocalNamesFV tv_names $ 
-    do { (ty', fvs1) <- rnLHsTyKi is_type doc ty
-       ; (res, fvs2) <- thing_inside (HsBSig ty' (kv_names, tv_names))
+    do { (ty', fvs1) <- rnLHsType doc ty
+       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
        ; return (res, fvs1 `plusFV` fvs2) } }
 
-checkHsBndrFlags :: Bool -> HsDocContext 
-                 -> LHsType RdrName -> [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 -> [RdrName] -> SDoc
-badKindBndrs doc _kind kvs
-  = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
+badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
+badKindBndrs doc kvs
+  = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
                  <+> pprQuotedList kvs)
               2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
          , docOfHsDocContext doc ]
@@ -779,7 +790,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
 %*********************************************************
 
 \begin{code}
-warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM ()
+warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
 warnUnusedForAlls in_doc bound mentioned_rdrs
   = ifWOptM Opt_WarnUnusedMatches $
     mapM_ add_warn bound_but_not_used
@@ -868,8 +879,6 @@ checkTH e what      -- Raise an error in a stage-1 compiler
 %*                                                                    *
 %************************************************************************
 
-extractHsTyRdrNames finds the free variables of a HsType
-It's used when making the for-alls explicit.
 
 Note [Kind and type-variable binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -902,7 +911,16 @@ See also Note [HsBSig binder lists] in HsTypes
 \begin{code}
 type FreeKiTyVars = ([RdrName], [RdrName])
 
+filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
+filterInScope rdr_env (kvs, tvs) 
+  = (filterOut in_scope kvs, filterOut in_scope tvs)
+  where
+    in_scope tv = tv `elemLocalRdrEnv` rdr_env
+
 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
+-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
+--                        or the free (sort, kind) variables of a HsKind
+-- It's used when making the for-alls explicit.
 -- See Note [Kind and type-variable binders]
 extractHsTyRdrTyVars ty 
   = case extract_lty ty ([],[]) of
@@ -914,12 +932,46 @@ extractHsTysRdrTyVars ty
   = case extract_ltys ty ([],[]) of
      (kvs, tvs) -> (nub kvs, nub tvs)
 
+extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
+extractRdrKindSigVars Nothing = []
+extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
+
+extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName]
+-- Get the scoped kind variables mentioned free in the constructor decls
+-- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+-- Here k should scope over the whole definition
+extractTyDefnKindVars (TySynonym { td_synRhs = ty}) 
+  = fst (extractHsTyRdrTyVars ty)
+extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig
+                              , td_cons = cons, td_derivs = derivs })
+  = fst $ extract_lctxt ctxt $
+          extract_mb extract_lkind ksig $
+          extract_mb extract_ltys derivs $
+          foldr (extract_con . unLoc) ([],[]) cons
+  where
+    extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
+    extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
+                         , con_cxt = ctxt, con_details = details }) acc
+      = extract_hs_tv_bndrs qvs acc $
+        extract_lctxt ctxt $
+        extract_ltys (hsConDeclArgTys details) ([],[])
+
+
 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
-extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
+extract_lctxt ctxt = extract_ltys (unLoc ctxt)
 
 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
 extract_ltys tys acc = foldr extract_lty acc tys
 
+extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
+extract_mb _ Nothing  acc = acc
+extract_mb f (Just x) acc = f x acc
+
+extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
+extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
+                                          (_, res_kvs) -> (res_kvs, acc_tvs)
+                                        -- Kinds shouldn't have sort signatures!
+
 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_lty (L _ ty) acc
   = case ty of
@@ -943,19 +995,27 @@ extract_lty (L _ ty) acc
       HsExplicitTupleTy _ tys   -> extract_ltys tys acc
       HsTyLit _                 -> acc
       HsWrapTy _ _              -> panic "extract_lty"
-      HsKindSig ty ki           -> case extract_lty ty acc of { (kvs1, tvs) ->
-                                   case extract_lty ki ([],kvs1) of { (_, kvs2) -> 
-                                        -- Kinds shouldn't have sort signatures!
-                                   (kvs2, tvs) }}
-      HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
-      HsForAllTy _ tvs cx ty    -> (acc_kvs ++ body_kvs, 
-                                    acc_tvs ++ filterOut (`elem` locals_tvs) body_tvs)
-                                where
-                                   (body_kvs, body_tvs) = extract_lctxt cx (extract_lty ty ([],[]))
-                                   (acc_kvs, acc_tvs) = acc
-                                   locals_tvs = hsLTyVarNames tvs
-                                        -- Currently we don't have a syntax to explicity bind 
-                                        -- kind variables, so these are all type variables
+      HsKindSig ty ki           -> extract_lty ty (extract_lkind ki acc)
+      HsForAllTy _ tvs cx ty    -> extract_hs_tv_bndrs tvs acc $
+                                   extract_lctxt cx   $
+                                   extract_lty ty ([],[])
+
+extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
+                    -> FreeKiTyVars -> FreeKiTyVars
+extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) 
+                    acc@(acc_kvs, acc_tvs)   -- Note accumulator comes first
+                    (body_kvs, body_tvs)
+  | null tvs
+  = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
+  | otherwise
+  = (outer_kvs ++ body_kvs,
+     outer_tvs ++ filterOut (`elem` local_tvs) body_tvs)
+  where
+    local_tvs = map hsLTyVarName tvs
+        -- Currently we don't have a syntax to explicitly bind 
+        -- kind variables, so these are all type variables
+
+    (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs]
 
 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_tv tv acc
index 83ecd8b..09704fb 100644 (file)
@@ -242,7 +242,8 @@ coVarsOfTcCo tc_co
     go (TcNthCo _ co)            = go co
     go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs
                                    `minusVarSet` get_bndrs bs
-    go (TcLetCo {}) = pprPanic "coVarsOfTcCo called on non-zonked TcCoercion" (ppr tc_co)
+    go (TcLetCo {}) = emptyVarSet    -- Harumph. This does legitimately happen in the call
+                                     -- to evVarsOfTerm in the DEBUG check of setEvBind
 
     -- We expect only coercion bindings
     go_bind :: EvBind -> VarSet
index 24cd442..b780c3b 100644 (file)
@@ -783,24 +783,19 @@ then we'd also need
                           since we only have BOX for a super kind)
 
 \begin{code}
-bindScopedKindVars :: [LHsTyVarBndr Name] -> TcM a -> TcM a
+bindScopedKindVars :: [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 ]
+bindScopedKindVars kvs thing_inside 
+  = tcExtendTyVarEnv (map mkKindSigVar kvs) thing_inside
 
-tcHsTyVarBndrs :: [LHsTyVarBndr Name] 
+tcHsTyVarBndrs :: LHsTyVarBndrs 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 $
+tcHsTyVarBndrs (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
+  = bindScopedKindVars kvs $
     do { tvs <- mapM tcHsTyVarBndr hs_tvs
        ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs)
        ; tcExtendTyVarEnv tvs (thing_inside tvs) }
@@ -825,7 +820,7 @@ tcHsTyVarBndr (L _ hs_tv)
            _ -> do
        { kind <- case hs_tv of
                    UserTyVar {} -> newMetaKindVar
-                   KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
+                   KindedTyVar _ kind -> tcLHsKind kind
        ; return (mkTcTyVar name kind (SkolemTv False)) } } }
 
 ------------------
@@ -896,11 +891,11 @@ kcLookupKind nm
            AGlobal (ATyCon tc) -> return (tyConKind tc)
            _                   -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
 
-kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a
+kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> (TcKind -> TcM a) -> TcM a
 -- Used for the type variables of a type or class decl,
 -- when doing the initial kind-check.  
-kcTyClTyVars name hs_tvs thing_inside
-  = bindScopedKindVars hs_tvs $
+kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
+  = bindScopedKindVars kvs $
     do         { tc_kind <- kcLookupKind name
        ; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind
                      -- There should be enough arrows, because
@@ -912,7 +907,7 @@ kcTyClTyVars name hs_tvs thing_inside
     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
+    kc_tv (L _ (KindedTyVar n hs_k)) exp_k
       = do { k <- tcLHsKind hs_k
            ; _ <- unifyKind k exp_k
            ; check_in_scope n exp_k
@@ -930,7 +925,7 @@ kcTyClTyVars name hs_tvs thing_inside
                Just thing      -> pprPanic "check_in_scope" (ppr thing) }
 
 -----------------------
-tcTyClTyVars :: Name -> [LHsTyVarBndr Name]    -- LHS of the type or class decl
+tcTyClTyVars :: Name -> LHsTyVarBndrs 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
@@ -1051,16 +1046,16 @@ Historical note:
 
 \begin{code}
 tcHsPatSigType :: UserTypeCtxt
-              -> HsBndrSig (LHsType Name)  -- The type signature
-             -> TcM ( Type                 -- The signature
-                      , [(Name, TcTyVar)] ) -- The new bit of type environment, binding
-                                           -- the scoped type variables
+              -> HsWithBndrs (LHsType Name)  -- The type signature
+             -> TcM ( Type                   -- The signature
+                      , [(Name, TcTyVar)] )   -- The new bit of type environment, binding
+                                             -- the scoped type variables
 -- 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 (HsBSig hs_ty (sig_kvs, sig_tvs))
+tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig_tvs })
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
     do { kvs <- mapM new_kv sig_kvs
         ; tvs <- mapM new_tv sig_tvs
@@ -1081,7 +1076,7 @@ tcHsPatSigType ctxt (HsBSig hs_ty (sig_kvs, sig_tvs))
           _              -> newSigTyVar name kind  -- See Note [Unifying SigTvs]
 
 tcPatSig :: UserTypeCtxt
-        -> HsBndrSig (LHsType Name)
+        -> HsWithBndrs (LHsType Name)
         -> TcSigmaType
         -> TcM (TcType,            -- The type to use for "inside" the signature
                 [(Name, TcTyVar)], -- The new bit of type environment, binding
index 80c792f..2a9f6df 100644 (file)
@@ -1430,10 +1430,13 @@ getGhciStepIO = do
     let a_tv   = mkTcTyVarName fresh_a (fsLit "a")
         ghciM  = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
         ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+
+        stepTy :: LHsType Name    -- Renamed, so needs all binders in place
         stepTy = noLoc $ HsForAllTy Implicit
-                      ([noLoc $ UserTyVar a_tv])
-                      (noLoc [])
-                      (nlHsFunTy ghciM ioM)
+                            (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
+                                    , hsq_kvs = [] })
+                            (noLoc [])
+                            (nlHsFunTy ghciM ioM)
         step   = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
     return step
 
index 7d86d15..287783c 100644 (file)
@@ -137,6 +137,9 @@ import TcRnTypes
 
 import Unique 
 import UniqFM
+#ifdef DEBUG
+import Digraph
+#endif
 import Maybes ( orElse, catMaybes )
 
 
@@ -960,10 +963,32 @@ runTcS context untouch is wl tcs
          }
              -- And return
        ; ev_binds <- TcM.getTcEvBinds ev_binds_var
+       ; checkForCyclicBinds ev_binds
        ; return (res, ev_binds) }
   where
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
 
+checkForCyclicBinds :: Bag EvBind -> TcM ()
+#ifndef DEBUG
+checkForCyclicBinds _ = return ()
+#else
+checkForCyclicBinds ev_binds
+  | null cycles 
+  = return ()
+  | null coercion_cycles
+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles
+  | otherwise
+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
+  where
+    cycles :: [[EvBind]]
+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges]
+
+    coercion_cycles = [c | c <- cycles, any is_co_bind c]
+    is_co_bind (EvBind b _) = isEqVar b
+
+    edges :: [(EvBind, EvVar, [EvVar])]
+    edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds]
+#endif       
 
 doWithInert :: InertSet -> TcS a -> TcS a 
 doWithInert inert (TcS action)
@@ -1368,36 +1393,11 @@ freshGoals :: [MaybeNew] -> [CtEvidence]
 freshGoals mns = [ ctev | Fresh ctev <- mns ]
 
 setEvBind :: EvVar -> EvTerm -> TcS ()
-setEvBind the_ev t
-  = do { tc_evbinds <- getTcEvBinds
-       ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev t
-
-       ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev
-                                     , text "t  =" <+> ppr t ]
-
-#ifndef DEBUG
-       ; return () }
-#else
-       ; binds <- getTcEvBindsMap
-       ; let cycle = reaches_tm binds t
-       ; when cycle (fail_if_co_loop binds) }
-
-  where fail_if_co_loop binds
-          = do { traceTcS "Cycle in evidence binds" $ vcat [ text "evvar =" <+> ppr the_ev
-                                                           , ppr (evBindMapBinds binds) ]
-               ; when (isEqVar the_ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) }
-
-        reaches_tm :: EvBindMap -> EvTerm -> Bool
-        -- Does any free variable of 'tm' reach 'the_ev'
-        reaches_tm ebm tm = foldVarSet ((||) . reaches ebm) False (evVarsOfTerm tm)
-
-        reaches :: EvBindMap -> Var -> Bool 
-        -- Does this evvar reach the_ev? 
-        reaches ebm ev 
-          | ev == the_ev                                 = True
-          | Just (EvBind _ evtrm) <- lookupEvBind ebm ev = reaches_tm ebm evtrm
-          | otherwise                                    = False
-#endif
+setEvBind the_ev tm
+  = do { traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev
+                                     , text "tm  =" <+> ppr tm ]
+       ; tc_evbinds <- getTcEvBinds
+       ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm }
 
 newGivenEvVar :: GivenLoc -> TcPredType -> EvTerm -> TcS CtEvidence
 -- Make a new variable of the given PredType, 
@@ -1684,6 +1684,7 @@ getCtCoercion _bs ct
   = ASSERT( not (isDerivedCt ct) )
     evTermCoercion (ctEvTerm (ctEvidence ct))
 {-       ToDo: check with Dimitrios that we can dump this stuff
+         WARNING: if we *do* need this stuff, we need to think again about cyclic bindings.
   = case lookupEvBind bs cc_id of
         -- Given and bound to a coercion term
       Just (EvBind _ (EvCoercion co)) -> co
index b880294..114140c 100644 (file)
@@ -335,9 +335,9 @@ getInitialKinds (L _ decl)
            --   data T :: *->* where { ... }
             -- with *no* tvs in the HsTyDefn
 
-    get_tvs (TyFamily    {tcdTyVars = tvs}) = tvs
-    get_tvs (ClassDecl   {tcdTyVars = tvs}) = tvs    
-    get_tvs (TyDecl      {tcdTyVars = tvs}) = tvs
+    get_tvs (TyFamily    {tcdTyVars = tvs}) = hsQTvBndrs tvs
+    get_tvs (ClassDecl   {tcdTyVars = tvs}) = hsQTvBndrs tvs    
+    get_tvs (TyDecl      {tcdTyVars = tvs}) = hsQTvBndrs tvs
     get_tvs (ForeignType {})                = []
  
 ----------------
@@ -431,17 +431,13 @@ kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs
        ; return () }
 
 ------------------
-kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM ()
+kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
 kcResultKind Nothing res_k
   = discardResult (unifyKind res_k liftedTypeKind)
       --             type family F a 
       -- defaults to type family F a :: *
-kcResultKind (Just (HsBSig k (ss, ns))) res_k
-  = ASSERT( null ss )      -- Parser ensures that 
-                           --   type family F a :: (k :: s)
-                           -- is illegal
-    do { let kvs = map mkKindSigVar ns 
-       ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k)
+kcResultKind (Just k ) res_k
+  = do { k' <- tcLHsKind k
        ; discardResult (unifyKind k' res_k) }
 \end{code}
 
@@ -727,7 +723,7 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl)
 
 -----------------
 tcFamTyPats :: TyCon
-            -> HsBndrSig [LHsType Name] -- Patterns
+            -> HsWithBndrs [LHsType Name] -- Patterns
             -> (TcKind -> TcM ())       -- Kind checker for RHS
                                         -- result is ignored
             -> ([TKVar] -> [TcType] -> Kind -> TcM a)
@@ -743,7 +739,8 @@ tcFamTyPats :: TyCon
 -- In that case, the type variable 'a' will *already be in scope*
 -- (and, if C is poly-kinded, so will its kind parameter).
 
-tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside
+tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) 
+            kind_checker thing_inside
   = do { -- A family instance must have exactly the same number of type
          -- parameters as the family declaration.  You can't write
          --     type family F a :: * -> *
@@ -756,14 +753,16 @@ tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside
 
          -- Instantiate with meta kind vars
        ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs
+       ; loc <- getSrcSpanM
        ; let (arg_kinds, res_kind) 
                  = splitKindFunTysN fam_arity $
                    substKiWith fam_kvs fam_arg_kinds fam_body
+             hs_tvs = HsQTvs { hsq_kvs = kvars
+                             , hsq_tvs = userHsTyVarBndrs loc tvars }
 
          -- Kind-check and quantify
          -- See Note [Quantifying over family patterns]
-       ; typats <- tcExtendTyVarEnv (map mkKindSigVar kvars)      $
-                   tcHsTyVarBndrs (map (noLoc . UserTyVar) tvars) $ \ _ ->
+       ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ ->
                    do { kind_checker res_kind
                       ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds }
        ; let all_args = fam_arg_kinds ++ typats
@@ -1106,10 +1105,10 @@ consUseH98Syntax _                                             = True
 conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
 conRepresentibleWithH98Syntax
     (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
-        = null tvs && null (unLoc ctxt)
+        = null (hsQTvBndrs tvs) && null (unLoc ctxt)
 conRepresentibleWithH98Syntax
     (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
-        = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
+        = null (unLoc ctxt) && f t (hsLTyVarNames tvs)
     where -- Each type variable should be used exactly once in the
           -- result type, and the result type must just be the type
           -- constructor applied to type variables