Keep track of explicit kinding in HsTyVarBndr; plus fix Trac #3845

To print HsTypes correctly we should remember whether the Kind on
a HsTyVarBndr came from type inference, or was put there by the
user.  See Note [Printing KindedTyVars] in HsTypes.  So instead of
changing a UserTyVar to a KindedTyVar during kind checking, we
simply add a PostTcKind to the UserTyVar.

The change was provoked by Trac #3830, although other changes
mean that #3830 gets a diferent and better error message now.
So this patch is simply doing the Right Thing for the future.

This patch also fixes Trac #3845, which was caused by a *type splice*
not remembering the free *term variables* mentioned in it.  Result
was that we build a 'let' when it should have been 'letrec'.
Hence a new FreeVars field in HsSpliceTy.

While I was at it, I got rid of HsSpliceTyOut and use a PostTcKind
on HsSpliceTy instead, just like on the UserTyVar.

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7718e4f..43c4622 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -536,9 +536,10 @@ lookupTyVarBinds tvs m =
 --
 repTyVarBndrWithKind :: LHsTyVarBndr Name 
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 --
 repTyVarBndrWithKind :: LHsTyVarBndr Name 
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)

-repTyVarBndrWithKind (L _ (UserTyVar _))      = repPlainTV
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) = 
-  \nm -> repKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (UserTyVar {})) nm
+  = repPlainTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+  = repKind ki >>= repKindedTV nm

 
 -- represent a type context
 --
 
 -- represent a type context
 --

@@ -632,9 +633,9 @@ repTy (HsKindSig t k)       = do
                                 t1 <- repLTy t
                                 k1 <- repKind k
                                 repTSig t1 k1
                                 t1 <- repLTy t
                                 k1 <- repKind k
                                 repTSig t1 k1

-repTy (HsSpliceTy splice)   = repSplice splice
-repTy ty@(HsNumTy _)        = notHandled "Number types (for generics)" (ppr ty)
-repTy ty                   = notHandled "Exotic form of type" (ppr ty)
+repTy (HsSpliceTy splice _ _) = repSplice splice
+repTy ty@(HsNumTy _)          = notHandled "Number types (for generics)" (ppr ty)
+repTy ty                     = notHandled "Exotic form of type" (ppr ty)

 
 -- represent a kind
 --
 
 -- represent a kind
 --

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 01af78b..d14d04a 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -641,7 +641,7 @@ cvtTvs tvs = mapM cvt_tv tvs
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm) 
   = do { nm' <- tName nm
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm) 
   = do { nm' <- tName nm

-       ; returnL $ UserTyVar nm' 
+       ; returnL $ UserTyVar nm' placeHolderKind

        }
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
        }
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 000ed19..08d12b7 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -698,7 +698,7 @@ data ConDecl name
         -- ^ Constructor name.  This is used for the DataCon itself, and for
         -- the user-callable wrapper Id.
 
         -- ^ Constructor name.  This is used for the DataCon itself, and for
         -- the user-callable wrapper Id.
 

-    , con_explicit  :: HsExplicitForAll
+    , con_explicit  :: HsExplicitFlag

         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
     , con_qvars     :: [LHsTyVarBndr name]
         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
     , con_qvars     :: [LHsTyVarBndr name]

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 4417751..2e2eaab 100644 (file)
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -9,7 +9,7 @@ HsTypes: Abstract syntax: user-defined types
 module HsTypes (
        HsType(..), LHsType, 
        HsTyVarBndr(..), LHsTyVarBndr,
 module HsTypes (
        HsType(..), LHsType, 
        HsTyVarBndr(..), LHsTyVarBndr,

-       HsExplicitForAll(..),
+       HsExplicitFlag(..),

        HsContext, LHsContext,
        HsPred(..), LHsPred,
        HsQuasiQuote(..),
        HsContext, LHsContext,
        HsPred(..), LHsPred,
        HsQuasiQuote(..),

@@ -21,20 +21,21 @@ module HsTypes (
        
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
        hsTyVarName, hsTyVarNames, replaceTyVarName,
        
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
        hsTyVarName, hsTyVarNames, replaceTyVarName,

+       hsTyVarKind, hsTyVarNameKind,

        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy, splitHsFunType,
        
        -- Type place holder
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy, splitHsFunType,
        
        -- Type place holder

-       PostTcType, placeHolderType,
+       PostTcType, placeHolderType, PostTcKind, placeHolderKind,

 
        -- Printing
 
        -- Printing

-       pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
+       pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,

     ) where
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
     ) where
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 

+import NameSet( FreeVars )

 import Type
 import Type

-import Coercion

 import HsDoc
 import BasicTypes
 import SrcLoc
 import HsDoc
 import BasicTypes
 import SrcLoc

@@ -51,6 +52,7 @@ import FastString
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+type PostTcKind = Kind

 type PostTcType = Type         -- Used for slots in the abstract syntax
                                -- where we want to keep slot for a type
                                -- to be added by the type checker...but
 type PostTcType = Type         -- Used for slots in the abstract syntax
                                -- where we want to keep slot for a type
                                -- to be added by the type checker...but

@@ -58,6 +60,9 @@ type PostTcType = Type                -- Used for slots in the abstract syntax
 
 placeHolderType :: PostTcType  -- Used before typechecking
 placeHolderType  = panic "Evaluated the place holder for a PostTcType"
 
 placeHolderType :: PostTcType  -- Used before typechecking
 placeHolderType  = panic "Evaluated the place holder for a PostTcType"

+
+placeHolderKind :: PostTcKind  -- Used before typechecking
+placeHolderKind  = panic "Evaluated the place holder for a PostTcKind"

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -134,7 +139,7 @@ data HsPred name = HsClassP name [LHsType name]              -- class constraint
 type LHsType name = Located (HsType name)
 
 data HsType name
 type LHsType name = Located (HsType name)
 
 data HsType name

-  = HsForAllTy HsExplicitForAll        -- Renamer leaves this flag unchanged, to record the way
+  = HsForAllTy HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way

                                        -- the user wrote it originally, so that the printer can
                                        -- print it as the user wrote it
                [LHsTyVarBndr name]     -- With ImplicitForAll, this is the empty list
                                        -- the user wrote it originally, so that the printer can
                                        -- print it as the user wrote it
                [LHsTyVarBndr name]     -- With ImplicitForAll, this is the empty list

@@ -179,20 +184,18 @@ data HsType name
   | HsKindSig          (LHsType name)  -- (ty :: kind)
                        Kind            -- A type with a kind signature
 
   | HsKindSig          (LHsType name)  -- (ty :: kind)
                        Kind            -- A type with a kind signature
 

-  | HsSpliceTy         (HsSplice name)

   | HsQuasiQuoteTy     (HsQuasiQuote name)
 
   | HsQuasiQuoteTy     (HsQuasiQuote name)
 

-  | HsDocTy             (LHsType name) LHsDocString -- A documented type
+  | HsSpliceTy         (HsSplice name) 
+                        FreeVars       -- Variables free in the splice (filled in by renamer)
+                       PostTcKind

 
 

-  | HsSpliceTyOut       Kind           -- Used just like KindedTyVar, just between 
-                                       --   kcHsType and dsHsType
+  | HsDocTy             (LHsType name) LHsDocString -- A documented type

 
   | HsBangTy   HsBang (LHsType name)   -- Bang-style type annotations 
   | HsRecTy [ConDeclField name]                -- Only in data type declarations
 
 
   | HsBangTy   HsBang (LHsType name)   -- Bang-style type annotations 
   | HsRecTy [ConDeclField name]                -- Only in data type declarations
 

-data HsExplicitForAll = Explicit | Implicit
-
-
+data HsExplicitFlag = Explicit | Implicit

 
 data ConDeclField name -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
 
 data ConDeclField name -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,

@@ -215,13 +218,13 @@ mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -
 mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit [] ctxt ty
 mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
 
 mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit [] ctxt ty
 mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
 

-mkHsForAllTy :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
+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
 
 -- mk_forall_ty makes a pure for-all type (no context)
 -- 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
 
 -- mk_forall_ty makes a pure for-all type (no context)

-mk_forall_ty :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsType name -> HsType name
+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 (L noSrcSpan []) ty
 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 (L noSrcSpan []) ty

@@ -231,7 +234,7 @@ mk_forall_ty exp  tvs  ty                               = HsForAllTy exp tvs (L noSrcSpan []) ty
        --      (see the sigtype production in Parser.y.pp)
        --      so that (forall. ty) isn't implicitly quantified
 
        --      (see the sigtype production in Parser.y.pp)
        --      so that (forall. ty) isn't implicitly quantified
 

-plus :: HsExplicitForAll -> HsExplicitForAll -> HsExplicitForAll
+plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag

 Implicit `plus` Implicit = Implicit
 _        `plus` _        = Explicit
 
 Implicit `plus` Implicit = Implicit
 _        `plus` _        = Explicit
 

@@ -244,16 +247,29 @@ hsExplicitTvs _                                   = []
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
 data HsTyVarBndr name
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
 data HsTyVarBndr name

-  = UserTyVar name
-  | KindedTyVar name Kind
-       --  *** NOTA BENE *** A "monotype" in a pragma can have
-       -- for-alls in it, (mostly to do with dictionaries).  These
-       -- must be explicitly Kinded.
+  = UserTyVar          -- No explicit kinding
+         name          -- See Note [Printing KindedTyVars]
+         PostTcKind
+
+  | KindedTyVar 
+         name 
+         Kind 
+      --  *** NOTA BENE *** A "monotype" in a pragma can have
+      -- for-alls in it, (mostly to do with dictionaries).  These
+      -- must be explicitly Kinded.

 
 hsTyVarName :: HsTyVarBndr name -> name
 
 hsTyVarName :: HsTyVarBndr name -> name

-hsTyVarName (UserTyVar n)     = n
+hsTyVarName (UserTyVar n _)   = n

 hsTyVarName (KindedTyVar n _) = n
 
 hsTyVarName (KindedTyVar n _) = n
 

+hsTyVarKind :: HsTyVarBndr name -> Kind
+hsTyVarKind (UserTyVar _ k)   = k
+hsTyVarKind (KindedTyVar _ k) = k
+
+hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind)
+hsTyVarNameKind (UserTyVar n k)   = (n,k)
+hsTyVarNameKind (KindedTyVar n k) = (n,k)
+

 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 

@@ -270,7 +286,7 @@ hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
 hsLTyVarLocNames = map hsLTyVarLocName
 
 replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
 hsLTyVarLocNames = map hsLTyVarLocName
 
 replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2

-replaceTyVarName (UserTyVar _)     n' = UserTyVar n'
+replaceTyVarName (UserTyVar _ k)   n' = UserTyVar n' k

 replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
 \end{code}
 
 replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
 \end{code}
 

@@ -316,8 +332,8 @@ instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
 instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr ty = pprHsType ty
 
 instance (Outputable name) => Outputable (HsTyVarBndr name) where

-    ppr (UserTyVar name)        = ppr name
-    ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind
+    ppr (UserTyVar name _)      = ppr name
+    ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind]

 
 instance OutputableBndr name => Outputable (HsPred name) where
     ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)
 
 instance OutputableBndr name => Outputable (HsPred name) where
     ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)

@@ -328,11 +344,7 @@ instance OutputableBndr name => Outputable (HsPred name) where
 pprLHsType :: OutputableBndr name => LHsType name -> SDoc
 pprLHsType = pprParendHsType . unLoc
 
 pprLHsType :: OutputableBndr name => LHsType name -> SDoc
 pprLHsType = pprParendHsType . unLoc
 

-pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
-pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name
-                        | otherwise             = hsep [ppr name, dcolon, pprParendKind kind]
-
-pprHsForAll :: OutputableBndr name => HsExplicitForAll -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
+pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc

 pprHsForAll exp tvs cxt 
   | show_forall = forall_part <+> pprHsContext (unLoc cxt)
   | otherwise   = pprHsContext (unLoc cxt)
 pprHsForAll exp tvs cxt 
   | show_forall = forall_part <+> pprHsContext (unLoc cxt)
   | otherwise   = pprHsContext (unLoc cxt)

@@ -358,6 +370,17 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
        = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 
        = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 

+Note [Printing KindedTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #3830 reminded me that we should really only print the kind
+signature on a KindedTyVar if the kind signature was put there by the
+programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,
+rather than converting to KindedTyVars as before.
+
+(As it happens, the message in #3830 comes out a different way now,
+and the problem doesn't show up; but having the flag on a KindedTyVar
+seems like the Right Thing anyway.)
+

 \begin{code}
 pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
 pREC_TOP = 0  -- type   in ParseIface.y
 \begin{code}
 pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
 pREC_TOP = 0  -- type   in ParseIface.y

@@ -408,8 +431,7 @@ ppr_mono_ty _    (HsListTy ty)           = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)      = pabrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
 ppr_mono_ty _    (HsNumTy n)         = integer n  -- generics only
 ppr_mono_ty _    (HsPArrTy ty)      = pabrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
 ppr_mono_ty _    (HsNumTy n)         = integer n  -- generics only

-ppr_mono_ty _    (HsSpliceTy s)      = pprSplice s
-ppr_mono_ty _    (HsSpliceTyOut k)   = text "<splicety>" <> dcolon <> ppr k
+ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s

 
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $
 
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 37a7205..14193e0 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -28,6 +28,7 @@ import Coercion
 import Type
 import DataCon
 import Name
 import Type
 import DataCon
 import Name

+import NameSet

 import BasicTypes
 import SrcLoc
 import FastString
 import BasicTypes
 import SrcLoc
 import FastString

@@ -183,6 +184,9 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 mkHsSplice e = HsSplice unqualSplice e
 
 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 mkHsSplice e = HsSplice unqualSplice e
 

+mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
+mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
+

 unqualSplice :: RdrName
 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
                -- A name (uniquified later) to
 unqualSplice :: RdrName
 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
                -- A name (uniquified later) to

@@ -201,7 +205,7 @@ mkHsString s = HsString (mkFastString s)
 
 -------------
 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 
 -------------
 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]

-userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c56b0c1..3b51e58 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1014,11 +1014,9 @@ atype :: { LHsType RdrName }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
        | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
        | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }

-       | '$(' exp ')'                  { LL $ HsSpliceTy (mkHsSplice $2 ) }
-       | TH_ID_SPLICE                  { LL $ HsSpliceTy (mkHsSplice 
-                                                (L1 $ HsVar (mkUnqual varName 
-                                                               (getTH_ID_SPLICE $1)))) } -- $x
-
+       | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
+       | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $ 
+                                         mkUnqual varName (getTH_ID_SPLICE $1) }

 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 

@@ -1046,7 +1044,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
         | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }

-       : tyvar                         { L1 (UserTyVar (unLoc $1)) }
+       : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }

        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) 
                                                          (unLoc $4)) }
 
        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) 
                                                          (unLoc $4)) }
 

@@ -1364,8 +1362,8 @@ aexp2     :: { LHsExpr RdrName }
        -- Template Haskell Extension
        | TH_ID_SPLICE          { L1 $ HsSpliceE (mkHsSplice 
                                        (L1 $ HsVar (mkUnqual varName 
        -- Template Haskell Extension
        | TH_ID_SPLICE          { L1 $ HsSpliceE (mkHsSplice 
                                        (L1 $ HsVar (mkUnqual varName 

-                                                       (getTH_ID_SPLICE $1)))) } -- $x
-       | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               -- $( exp )
+                                                       (getTH_ID_SPLICE $1)))) } 
+       | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               

 
 
        | TH_VAR_QUOTE qvar     { LL $ HsBracket (VarBr (unLoc $2)) }
 
 
        | TH_VAR_QUOTE qvar     { LL $ HsBracket (VarBr (unLoc $2)) }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e0e8c3c..b83bcd9 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -128,7 +128,6 @@ extract_lty (L loc ty) acc
       HsNumTy _                 -> acc
       HsQuasiQuoteTy {}                -> acc  -- Quasi quotes mention no type variables
       HsSpliceTy {}            -> acc  -- Type splices mention no type variables
       HsNumTy _                 -> acc
       HsQuasiQuoteTy {}                -> acc  -- Quasi quotes mention no type variables
       HsSpliceTy {}            -> acc  -- Type splices mention no type variables

-      HsSpliceTyOut {}                 -> acc  -- Type splices mention no type variables

       HsKindSig ty _            -> extract_lty ty acc
       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
       HsKindSig ty _            -> extract_lty ty acc
       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $

@@ -503,8 +502,7 @@ checkTParams is_family tparams
   = do { tyvars <- checkTyVars tparams
        ; return (tyvars, Nothing) }
   | otherwise           -- Family case (b)
   = do { tyvars <- checkTyVars tparams
        ; return (tyvars, Nothing) }
   | otherwise           -- Family case (b)

-  = do { let tyvars = [L l (UserTyVar tv) 
-                      | L l tv <- extractHsTysRdrTyVars tparams]
+  = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)

        ; return (tyvars, Just tparams) }
 
 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
        ; return (tyvars, Just tparams) }
 
 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]

@@ -519,7 +517,7 @@ checkTyVars tparms = mapM chk tparms
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))

-        | isRdrTyVar tv    = return (L l (UserTyVar tv))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))

     chk (L l _)            =
          parseError l "Type found where type variable expected"
 
     chk (L l _)            =
          parseError l "Type found where type variable expected"
 

diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index cb0727b..60e0823 100644 (file)
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -68,9 +68,8 @@ extractHsTyNames ty
     get (HsRecTy flds)         = extractHsTyNames_s (map cd_fld_type flds)
     get (HsNumTy _)            = emptyNameSet
     get (HsTyVar tv)           = unitNameSet tv
     get (HsRecTy flds)         = extractHsTyNames_s (map cd_fld_type flds)
     get (HsNumTy _)            = emptyNameSet
     get (HsTyVar tv)           = unitNameSet tv

-    get (HsSpliceTy {})        = emptyNameSet   -- Type splices mention no type variables
-    get (HsSpliceTyOut {})     = emptyNameSet   -- Ditto
-    get (HsQuasiQuoteTy {})    = emptyNameSet   -- Ditto
+    get (HsSpliceTy _ fvs _)   = fvs
+    get (HsQuasiQuoteTy {})    = emptyNameSet

     get (HsKindSig ty _)       = getl ty
     get (HsForAllTy _ tvs
                     ctxt ty)   = (extractHsCtxtTyNames ctxt
     get (HsKindSig ty _)       = getl ty
     get (HsForAllTy _ tvs
                     ctxt ty)   = (extractHsCtxtTyNames ctxt

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index ed3e6d0..e2897ee 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -185,9 +185,9 @@ rnHsType doc (HsPredTy pred) = do
     pred' <- rnPred doc pred
     return (HsPredTy pred')
 
     pred' <- rnPred doc pred
     return (HsPredTy pred')
 

-rnHsType _ (HsSpliceTy sp)
-  = do { (sp', _fvs) <- rnSplice sp    -- ToDo: deal with fvs
-       ; return (HsSpliceTy sp') }
+rnHsType _ (HsSpliceTy sp _ k)
+  = do { (sp', fvs) <- rnSplice sp     -- ToDo: deal with fvs
+       ; return (HsSpliceTy sp' fvs k) }

 
 rnHsType doc (HsDocTy ty haddock_doc) = do
     ty' <- rnLHsType doc ty
 
 rnHsType doc (HsDocTy ty haddock_doc) = do
     ty' <- rnLHsType doc ty

@@ -200,7 +200,6 @@ rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHC
 rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
                                       ; rnHsType doc (unLoc ty) }
 #endif
 rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
                                       ; rnHsType doc (unLoc ty) }
 #endif

-rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType"

 
 rnLHsTypes :: SDoc -> [LHsType RdrName]
            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
 
 rnLHsTypes :: SDoc -> [LHsType RdrName]
            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]

@@ -209,7 +208,7 @@ rnLHsTypes doc tys = mapM (rnLHsType doc) tys
 
 
 \begin{code}
 
 
 \begin{code}

-rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
+rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]

         -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
         -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 2d113b7..0fb82cb 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -528,7 +528,8 @@ mkGenericInstance clas (hs_ty, binds) = do
        -- and wrap them as forall'd tyvars, so that kind inference
        -- works in the standard way
     let
        -- and wrap them as forall'd tyvars, so that kind inference
        -- works in the standard way
     let

-       sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
+       sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
+                  extractHsTyVars (noLoc hs_ty)

        hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 
        -- Type-check the instance type, and check its form
        hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 
        -- Type-check the instance type, and check its form

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index bcc2169..bb4bb8d 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -319,13 +319,10 @@ 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]
 
     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] -> TcM r -> TcM r
+tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r

 tcExtendKindEnvTvs bndrs thing_inside
 tcExtendKindEnvTvs bndrs thing_inside

-  = updLclEnv upd thing_inside
-  where
-    upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
-    extend env  = extendNameEnvList env pairs
-    pairs       = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
+  = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
+                    (thing_inside bndrs)

 
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
 
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index bcf1f07..3fb1848 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1598,7 +1598,8 @@ genAuxBind loc (GenCon2Tag tycon)
     get_tag_rhs = L loc $ ExprWithTySig 
                        (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) 
                                              (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
     get_tag_rhs = L loc $ ExprWithTySig 
                        (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) 
                                              (nlHsApp (nlHsVar getTag_RDR) a_Expr)))

-                       (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
+                       (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs)) 
+                                                     (noLoc []) con2tag_ty))

 
     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
                `nlHsFunTy` 
 
     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
                `nlHsFunTy` 

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 64da3c0..62c5eaa 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -16,7 +16,7 @@ module TcHsType (
        
                -- Typechecking kinded types
        tcHsKindedContext, tcHsKindedType, tcHsBangType,
        
                -- Typechecking kinded types
        tcHsKindedContext, tcHsKindedType, tcHsBangType,

-       tcTyVarBndrs, dsHsType, tcLHsConResTy,
+       tcTyVarBndrs, dsHsType, 

        tcDataKindSig, ExpKind(..), EkCtxt(..),
 
                -- Pattern type signatures
        tcDataKindSig, ExpKind(..), EkCtxt(..),
 
                -- Pattern type signatures

@@ -419,12 +419,11 @@ kc_hs_type ty@(HsRecTy _)
       -- should have been removed by now
 
 #ifdef GHCI    /* Only if bootstrapped */
       -- should have been removed by now
 
 #ifdef GHCI    /* Only if bootstrapped */

-kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
+kc_hs_type (HsSpliceTy sp fvs _) = kcSpliceType sp fvs

 #else
 kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
 #endif
 
 #else
 kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
 #endif
 

-kc_hs_type (HsSpliceTyOut {})  = panic "kc_hs_type"    -- Should not happen at all

 kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type"    -- Eliminated by renamer
 
 -- remove the doc nodes here, no need to worry about the location since
 kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type"    -- Eliminated by renamer
 
 -- remove the doc nodes here, no need to worry about the location since

@@ -624,11 +623,10 @@ ds_type (HsForAllTy _ tv_names ctxt ty)
 ds_type (HsDocTy ty _)  -- Remove the doc comment
   = dsHsType ty
 
 ds_type (HsDocTy ty _)  -- Remove the doc comment
   = dsHsType ty
 

-ds_type (HsSpliceTyOut kind) 
+ds_type (HsSpliceTy _ _ kind) 

   = do { kind' <- zonkTcKindToKind kind
        ; newFlexiTyVarTy kind' }
 
   = do { kind' <- zonkTcKindToKind kind
        ; newFlexiTyVarTy kind' }
 

-ds_type (HsSpliceTy {})     = panic "ds_type"

 ds_type (HsQuasiQuoteTy {}) = panic "ds_type"  -- Eliminated by renamer
 
 dsHsTypes :: [LHsType Name] -> TcM [Type]
 ds_type (HsQuasiQuoteTy {}) = panic "ds_type"  -- Eliminated by renamer
 
 dsHsTypes :: [LHsType Name] -> TcM [Type]

@@ -684,35 +682,7 @@ dsHsPred (HsIParam name ty)
        }
 \end{code}
 
        }
 \end{code}
 

-GADT constructor signatures
-

 \begin{code}
 \begin{code}

-tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy (L span res_ty)
-  = setSrcSpan span $
-    case get_args res_ty [] of
-          (HsTyVar tc_name, args) 
-             -> do { args' <- mapM dsHsType args
-                   ; thing <- tcLookup tc_name
-                   ; case thing of
-                       AGlobal (ATyCon tc) -> return (tc, args')
-                       _ -> failWithTc (badGadtDecl res_ty) }
-          _ -> failWithTc (badGadtDecl res_ty)
-  where
-       -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe
-       -- because that causes a black hole, and for good reason.  Building
-       -- the type means expanding type synonyms, and we can't do that
-       -- inside the "knot".  So we have to work by steam.
-    get_args (HsAppTy (L _ fun) arg)   args = get_args fun (arg:args)
-    get_args (HsParTy (L _ ty))        args = get_args ty  args
-    get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
-    get_args ty                        args = (ty, args)
-
-badGadtDecl :: HsType Name -> SDoc
-badGadtDecl ty
-  = hang (ptext (sLit "Malformed constructor result type:"))
-       2 (ppr ty)
-

 addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
        -- Wrap a context around only if we want to show that contexts.  
 addKcTypeCtxt (L _ (HsPredTy _)) thing = thing
 addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
        -- Wrap a context around only if we want to show that contexts.  
 addKcTypeCtxt (L _ (HsPredTy _)) thing = thing

@@ -735,14 +705,14 @@ kcHsTyVars :: [LHsTyVarBndr Name]
           -> ([LHsTyVarBndr Name] -> TcM r)    -- These binders are kind-annotated
                                                -- They scope over the thing inside
           -> TcM r
           -> ([LHsTyVarBndr Name] -> TcM r)    -- These binders are kind-annotated
                                                -- They scope over the thing inside
           -> TcM r

-kcHsTyVars tvs thing_inside  = do
-    bndrs <- mapM (wrapLocM kcHsTyVar) tvs
-    tcExtendKindEnvTvs bndrs (thing_inside bndrs)
+kcHsTyVars tvs thing_inside
+  = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs
+       ; tcExtendKindEnvTvs kinded_tvs thing_inside }

 
 kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
        -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it      
 
 kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
        -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it      

-kcHsTyVar (UserTyVar name)        = KindedTyVar name <$> newKindVar
-kcHsTyVar (KindedTyVar name kind) = return (KindedTyVar name kind)
+kcHsTyVar (UserTyVar name _)  = UserTyVar name <$> newKindVar
+kcHsTyVar tv@(KindedTyVar {}) = return tv

 
 ------------------
 tcTyVarBndrs :: [LHsTyVarBndr Name]    -- Kind-annotated binders, which need kind-zonking
 
 ------------------
 tcTyVarBndrs :: [LHsTyVarBndr Name]    -- Kind-annotated binders, which need kind-zonking

@@ -754,10 +724,9 @@ tcTyVarBndrs bndrs thing_inside = do
     tyvars <- mapM (zonk . unLoc) bndrs
     tcExtendTyVarEnv tyvars (thing_inside tyvars)
   where
     tyvars <- mapM (zonk . unLoc) bndrs
     tcExtendTyVarEnv tyvars (thing_inside tyvars)
   where

-    zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
-                                     ; return (mkTyVar name kind') }
-    zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name )
-                           return (mkTyVar name liftedTypeKind)
+    zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind
+                                   ; return (mkTyVar name kind') }
+    zonk (KindedTyVar name kind) = return (mkTyVar name kind)

 
 -----------------------------------
 tcDataKindSig :: Maybe Kind -> TcM [TyVar]
 
 -----------------------------------
 tcDataKindSig :: Maybe Kind -> TcM [TyVar]

@@ -867,9 +836,9 @@ tcHsPatSigType ctxt hs_ty
                -- should be bound by the pattern signature
          in_scope <- getInLocalScope
        ; let span = getLoc hs_ty
                -- should be bound by the pattern signature
          in_scope <- getInLocalScope
        ; let span = getLoc hs_ty

-             sig_tvs = [ L span (UserTyVar n) 
-                       | n <- nameSetToList (extractHsTyVars hs_ty),
-                         not (in_scope n) ]
+             sig_tvs = userHsTyVarBndrs $ map (L span) $ 
+                       filterOut in_scope $
+                        nameSetToList (extractHsTyVars hs_ty)

 
        ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
        ; checkValidType ctxt sig_ty 
 
        ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
        ; checkValidType ctxt sig_ty 

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 8ee43f5..d67a57b 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -46,6 +46,7 @@ import TcIface
 import TypeRep
 import Name
 import NameEnv
 import TypeRep
 import Name
 import NameEnv

+import NameSet

 import PrelNames
 import HscTypes
 import OccName
 import PrelNames
 import HscTypes
 import OccName

@@ -284,7 +285,7 @@ The predicate we use is TcEnv.thTopLevelId.
 tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
 tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)

-kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
+kcSpliceType  :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)

        -- None of these functions add constraints to the LIE
 
 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
        -- None of these functions add constraints to the LIE
 
 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)

@@ -300,7 +301,7 @@ runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
 tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
 tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
 tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
 tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
 tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)

-kcSpliceType  x   = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
+kcSpliceType  x fvs = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)

 
 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
 
 
 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
 

@@ -495,7 +496,7 @@ tcTopSpliceExpr tc_action
 Very like splicing an expression, but we don't yet share code.
 
 \begin{code}
 Very like splicing an expression, but we don't yet share code.
 
 \begin{code}

-kcSpliceType (HsSplice name hs_expr)
+kcSpliceType splice@(HsSplice name hs_expr) fvs

   = setSrcSpan (getLoc hs_expr) $ do   
     { stage <- getStage
     ; case stage of {
   = setSrcSpan (getLoc hs_expr) $ do   
     { stage <- getStage
     ; case stage of {

@@ -518,11 +519,8 @@ kcSpliceType (HsSplice name hs_expr)
     -- Here (h 4) :: Q Type
     -- but $(h 4) :: a         i.e. any type, of any kind
 
     -- Here (h 4) :: Q Type
     -- but $(h 4) :: a         i.e. any type, of any kind
 

-    -- We return a HsSpliceTyOut, which serves to convey the kind to 
-    -- the ensuing TcHsType.dsHsType, which makes up a non-committal
-    -- type variable of a suitable kind

     ; kind <- newKindVar
     ; kind <- newKindVar

-    ; return (HsSpliceTyOut kind, kind)        
+    ; return (HsSpliceTy splice fvs kind, kind)        

     }}}
 
 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
     }}}
 
 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)

diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot
index 32d3e5a..d8cd81b 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs-boot
+++ b/compiler/typecheck/TcSplice.lhs-boot
@@ -3,6 +3,7 @@ module TcSplice where
 import HsSyn   ( HsSplice, HsBracket, HsQuasiQuote,
                   HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl )
 import Name    ( Name )
 import HsSyn   ( HsSplice, HsBracket, HsQuasiQuote,
                   HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl )
 import Name    ( Name )

+import NameSet ( FreeVars )

 import RdrName ( RdrName )
 import TcRnTypes( TcM, TcId )
 import TcType  ( BoxyRhoType, TcKind )
 import RdrName ( RdrName )
 import TcRnTypes( TcM, TcId )
 import TcType  ( BoxyRhoType, TcKind )

@@ -13,7 +14,7 @@ tcSpliceExpr :: HsSplice Name
             -> BoxyRhoType
             -> TcM (HsExpr TcId)
 
             -> BoxyRhoType
             -> TcM (HsExpr TcId)
 

-kcSpliceType :: HsSplice Name
+kcSpliceType :: HsSplice Name -> FreeVars

             -> TcM (HsType Name, TcKind)
 
 tcBracket :: HsBracket Name 
             -> TcM (HsType Name, TcKind)
 
 tcBracket :: HsBracket Name 

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 9c3abc5..229e997 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -481,7 +481,7 @@ getInitialKind decl
        ; res_kind  <- mk_res_kind decl
        ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
   where
        ; res_kind  <- mk_res_kind decl
        ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
   where

-    mk_arg_kind (UserTyVar _)        = newKindVar
+    mk_arg_kind (UserTyVar _ _)      = newKindVar

     mk_arg_kind (KindedTyVar _ kind) = return kind
 
     mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
     mk_arg_kind (KindedTyVar _ kind) = return kind
 
     mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind

@@ -513,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl))
                        <+> brackets (ppr k_tvs))
        ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
        ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
                        <+> brackets (ppr k_tvs))
        ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
        ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))

-       ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
+       ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs

        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
                 (unLoc (tcdLName decl), tc_kind)) })
 
        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
                 (unLoc (tcdLName decl), tc_kind)) })
 

@@ -521,10 +521,6 @@ kcSynDecl (CyclicSCC decls)
   = do { recSynErr decls; failM }      -- Fail here to avoid error cascade
                                        -- of out-of-scope tycons
 
   = do { recSynErr decls; failM }      -- Fail here to avoid error cascade
                                        -- of out-of-scope tycons
 

-kindedTyVarKind :: LHsTyVarBndr Name -> Kind
-kindedTyVarKind (L _ (KindedTyVar _ k)) = k
-kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x)
-

 ------------------------------------------------------------------------
 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
        -- Not used for type synonyms (see kcSynDecl)
 ------------------------------------------------------------------------
 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
        -- Not used for type synonyms (see kcSynDecl)

@@ -566,14 +562,16 @@ kcTyClDeclBody decl thing_inside
   = tcAddDeclCtxt decl         $
     do         { tc_ty_thing <- tcLookupLocated (tcdLName decl)
        ; let tc_kind    = case tc_ty_thing of
   = tcAddDeclCtxt decl         $
     do         { tc_ty_thing <- tcLookupLocated (tcdLName decl)
        ; let tc_kind    = case tc_ty_thing of

-                           AThing k -> k
-                           _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
+                             AThing k -> k
+                             _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)

              (kinds, _) = splitKindFunTys tc_kind
              hs_tvs     = tcdTyVars decl
              kinded_tvs = ASSERT( length kinds >= length hs_tvs )
              (kinds, _) = splitKindFunTys tc_kind
              hs_tvs     = tcdTyVars decl
              kinded_tvs = ASSERT( length kinds >= length hs_tvs )

-                          [ L loc (KindedTyVar (hsTyVarName tv) k)
-                          | (L loc tv, k) <- zip hs_tvs kinds]
-       ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
+                          zipWith add_kind hs_tvs kinds
+       ; tcExtendKindEnvTvs kinded_tvs thing_inside }
+  where
+    add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
+    add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)

 
 -- Kind check a data declaration, assuming that we already extended the
 -- kind environment with the type variables of the left-hand side (these
 
 -- Kind check a data declaration, assuming that we already extended the
 -- kind environment with the type variables of the left-hand side (these

@@ -633,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
                       -- default result kind is '*'
        }
   where
                       -- default result kind is '*'
        }
   where

-    unifyClassParmKinds (L _ (KindedTyVar n k))
-      | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind
-      | otherwise                                   = return ()
-    unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x)
-    classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs]
+    unifyClassParmKinds (L _ tv) 
+      | (n,k) <- hsTyVarNameKind tv
+      , Just classParmKind <- lookup n classTyKinds 
+      = unifyKind k classParmKind
+      | otherwise = return ()
+    classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
+

 kcFamilyDecl _ (TySynonym {})              -- type family defaults
   = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
 kcFamilyDecl _ (TySynonym {})              -- type family defaults
   = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)