Deal with kind variables brought into scope by a kind signature
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 14 Mar 2012 17:26:20 +0000 (17:26 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 14 Mar 2012 17:26:20 +0000 (17:26 +0000)
This fixes Trac #5937, where a kind variable is mentioned only
in the kind signature of a GADT
   data SMaybe :: (k -> *) -> Maybe k -> * where ...

The main change is that the tcdKindSig field of TyData and TyFamily
now has type Maybe (HsBndrSig (LHsKind name)), where the HsBndrSig
part deals with the kind variables that the signature may bind.

I also removed the now-unused PostTcKind field of UserTyVar and
KindedTyVar.

compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcTyClsDecls.lhs

index 26d49f7..d323169 100644 (file)
@@ -452,7 +452,7 @@ data TyClDecl name
     TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
                 tcdLName   :: Located name,              -- type constructor
                 tcdTyVars  :: [LHsTyVarBndr name],       -- type variables
-                tcdKindSig :: Maybe (LHsKind name)       -- result kind
+                tcdKindSig :: Maybe (HsBndrSig (LHsKind name))  -- result kind
     }
 
 
@@ -470,7 +470,7 @@ data TyClDecl name
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
                   -- See Note [tcdTyVars and tcdTyPats] 
 
-                tcdKindSig:: Maybe (LHsKind name),
+                tcdKindSig:: Maybe (HsBndrSig (LHsKind name)),
                         -- ^ Optional kind signature.
                         --
                         -- @(Just k)@ for a GADT-style @data@, or @data
@@ -667,7 +667,7 @@ instance OutputableBndr name
                   derivings
       where
         ppr_sigx Nothing     = empty
-        ppr_sigx (Just kind) = dcolon <+> ppr kind
+        ppr_sigx (Just (HsBSig kind _)) = dcolon <+> ppr kind
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,
index 696b48f..c0b1ceb 100644 (file)
@@ -30,7 +30,6 @@ module HsTypes (
        
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
        hsTyVarName, hsTyVarNames, 
-       hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
         splitHsForAllTy, splitLHsForAllTy,
@@ -143,12 +142,10 @@ 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.
@@ -374,19 +371,8 @@ hsExplicitTvs _                                   = []
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
-hsTyVarName (UserTyVar n _)   = n
-hsTyVarName (KindedTyVar n _ _) = n
-
-hsTyVarKind :: HsTyVarBndr name -> Kind
-hsTyVarKind (UserTyVar _ k)   = k
-hsTyVarKind (KindedTyVar _ _ k) = k
-
-hsLTyVarKind :: LHsTyVarBndr name -> Kind
-hsLTyVarKind  = hsTyVarKind . unLoc
-
-hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind)
-hsTyVarNameKind (UserTyVar n k)   = (n,k)
-hsTyVarNameKind (KindedTyVar n _ k) = (n,k)
+hsTyVarName (UserTyVar n)     = n
+hsTyVarName (KindedTyVar n _) = n
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -493,8 +479,8 @@ 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]
+    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 
index f7a1a10..729532d 100644 (file)
@@ -268,7 +268,7 @@ mkHsString s = HsString (mkFastString s)
 
 -------------
 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
-userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 \end{code}
 
 
index 8de1e0b..a377495 100644 (file)
@@ -722,9 +722,9 @@ data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
         | 'newtype'     { L1 NewType }
 
-opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
+opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
         :                               { noLoc Nothing }
-        | '::' kind                     { LL (Just $2) }
+        | '::' kind                     { LL (Just (HsBSig $2 placeHolderBndrs)) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -1101,8 +1101,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
          | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
-        : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) }
+        : tyvar                         { L1 (UserTyVar (unLoc $1)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs)) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
index 872bcde..4311c25 100644 (file)
@@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
                   where
                     bsig = HsBSig (toHsKind k) placeHolderBndrs
 
index be1f5c4..72fe1a2 100644 (file)
@@ -194,7 +194,7 @@ mkTyData :: SrcSpan
          -> Bool                -- True <=> data family instance
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe (LHsKind RdrName)
+         -> Maybe (HsBndrSig (LHsKind RdrName))
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
@@ -208,7 +208,8 @@ mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons m
                                  tcdCtxt = cxt, tcdLName = tc,
                                  tcdTyVars = tyvars, tcdTyPats = typats,
                                  tcdCons = data_cons,
-                                 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
+                                 tcdKindSig = ksig,
+                                 tcdDerivs = maybe_deriv })) }
 
 mkTySynonym :: SrcSpan
             -> Bool             -- True <=> type family instances
@@ -225,7 +226,7 @@ mkTySynonym loc is_family lhs rhs
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
            -> LHsType RdrName   -- LHS
-           -> Maybe (LHsKind RdrName) -- Optional kind signature
+           -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
@@ -501,9 +502,9 @@ 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 (HsBSig k placeHolderBndrs) placeHolderKind))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs)))
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L l _)
         = parseErrorSDoc l $
           vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
index 8c26f92..28ac999 100644 (file)
@@ -106,12 +106,13 @@ rnLHsType = rnLHsTyKi True
 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
 rnLHsKind = rnLHsTyKi False
 
-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) }
+rnLHsMaybeKind  :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
+                -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
+rnLHsMaybeKind _ Nothing 
+  = return (Nothing, emptyFVs)
+rnLHsMaybeKind doc (Just bsig) 
+  = rnHsBndrSig False doc bsig $ \ bsig' -> 
+    return (Just bsig', emptyFVs)
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsType = rnHsTyKi True
@@ -404,14 +405,14 @@ bindTyVarsRn doc tv_bndrs names thing_inside
   where
     go [] [] thing_inside = thing_inside []
 
-    go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside
+    go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside
       = go tvs ns $ \ tvs' ->
-        thing_inside (L loc (UserTyVar n tck) : tvs')
+        thing_inside (L loc (UserTyVar n) : tvs')
 
-    go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside
+    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' tck) : tvs')
+        thing_inside (L loc (KindedTyVar n bsig') : tvs')
 
     -- Lists of unequal length
     go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
index d97a088..604db4d 100644 (file)
@@ -20,7 +20,7 @@ module TcEnv(
         tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
         
         -- Local environment
-        tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
+        tcExtendKindEnv, tcExtendTcTyThingEnv,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
         tcExtendGhciEnv, tcExtendLetEnv,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
@@ -340,11 +340,6 @@ tcExtendKindEnv things thing_inside
     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
 
-tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
-tcExtendKindEnvTvs bndrs thing_inside
-  = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
-                    (thing_inside bndrs)
-
 -----------------------
 -- Scoped type and kind variables
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
index 276d695..cd95d7d 100644 (file)
@@ -785,7 +785,7 @@ bindScopedKindVars hs_tvs thing_inside
   where
     kvs :: [KindVar]   -- All skolems
     kvs = [ mkKindSigVar kv 
-          | L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs
+          | L _ (KindedTyVar _ (HsBSig _ kvs)) <- hs_tvs
           , kv <- kvs ]
 
 tcHsTyVarBndrs :: [LHsTyVarBndr Name] 
@@ -818,7 +818,7 @@ tcHsTyVarBndr (L _ hs_tv)
            _ -> do
        { kind <- case hs_tv of
                    UserTyVar {} -> newMetaKindVar
-                   KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
+                   KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
        ; return (mkTyVar name kind) } } }
 
 ------------------
@@ -908,7 +908,7 @@ kcLookupKind nm
            _                   -> 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,
+-- 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 $
@@ -920,10 +920,10 @@ kcTyClTyVars name hs_tvs thing_inside
         ; tcExtendKindEnv name_ks (thing_inside res_k) }
   where
     kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
-    kc_tv (L _ (UserTyVar n _)) exp_k 
+    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 (HsBSig hs_k _))) exp_k
       = do { k <- tcLHsKind hs_k
            ; _ <- unifyKind k exp_k
            ; check_in_scope n exp_k
index c166e62..b2b4089 100644 (file)
@@ -431,13 +431,14 @@ kcFamilyDecl (TySynonym {}) = return ()
 kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d)
 
 ------------------
-kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
+kcResultKind :: Maybe (HsBndrSig (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 k) res_k
-  = do { k' <- tcLHsKind k
+kcResultKind (Just (HsBSig k ns)) res_k
+  = do { let kvs = map mkKindSigVar ns 
+       ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k)
        ; discardResult (unifyKind k' res_k) }
 \end{code}