New kind-polymorphic core
authorJose Pedro Magalhaes <jpm@cs.uu.nl>
Fri, 11 Nov 2011 09:07:11 +0000 (09:07 +0000)
committerJose Pedro Magalhaes <jpm@cs.uu.nl>
Fri, 11 Nov 2011 09:09:23 +0000 (09:09 +0000)
This big patch implements a kind-polymorphic core for GHC. The current
implementation focuses on making sure that all kind-monomorphic programs still
work in the new core; it is not yet guaranteed that kind-polymorphic programs
(using the new -XPolyKinds flag) will work.

For more information, see http://haskell.org/haskellwiki/GHC/Kinds

88 files changed:
compiler/basicTypes/MkId.lhs
compiler/basicTypes/OccName.lhs
compiler/basicTypes/RdrName.lhs
compiler/basicTypes/Var.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/MkCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsMeta.hs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsExpr.lhs-boot
compiler/hsSyn/HsLit.lhs
compiler/hsSyn/HsPat.lhs-boot
compiler/hsSyn/HsTypes.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.lhs
compiler/main/TidyPgm.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp [changed mode: 0644->0755]
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/prelude/primops.txt.pp
compiler/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnExpr.lhs-boot
compiler/rename/RnHsSyn.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/simplCore/SetLevels.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/typecheck/TcUnify.lhs-boot
compiler/types/Class.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/Kind.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/Type.lhs-boot
compiler/types/TypeRep.lhs
compiler/types/TypeRep.lhs-boot
compiler/types/Unify.lhs
compiler/utils/Outputable.lhs
compiler/utils/Pretty.lhs
compiler/vectorise/Vectorise/Monad.hs

index a7184e0..c5f56d8 100644 (file)
@@ -1024,7 +1024,7 @@ voidArgId       -- :: State# RealWorld
 coercionTokenId :: Id        -- :: () ~ ()
 coercionTokenId -- Used to replace Coercion terms when we go to STG
   = pcMiscPrelId coercionTokenName 
-                 (mkTyConApp eqPrimTyCon [unitTy, unitTy])
+                 (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy])
                  noCafIdInfo
 \end{code}
 
index a48a7d4..fa86350 100644 (file)
@@ -53,6 +53,7 @@ module OccName (
         mkDFunOcc,
        mkTupleOcc, 
        setOccNameSpace,
+        demoteOccName,
 
        -- ** Derived 'OccName's
         isDerivedOccName,
@@ -204,8 +205,35 @@ pprNameSpaceBrief DataName  = char 'd'
 pprNameSpaceBrief VarName   = char 'v'
 pprNameSpaceBrief TvName    = ptext (sLit "tv")
 pprNameSpaceBrief TcClsName = ptext (sLit "tc")
+
+-- demoteNameSpace lowers the NameSpace if possible.  We can not know
+-- in advance, since a TvName can appear in an HsTyVar.
+-- see Note [Demotion]
+demoteNameSpace :: NameSpace -> Maybe NameSpace
+demoteNameSpace VarName = Nothing
+demoteNameSpace DataName = Nothing
+demoteNameSpace TvName = Nothing
+demoteNameSpace TcClsName = Just DataName
 \end{code}
 
+Note [Demotion]
+~~~~~~~~~~~~~~~
+
+When the user writes:
+  data Nat = Zero | Succ Nat
+  foo :: f Zero -> Int
+
+'Zero' in the type signature of 'foo' is parsed as:
+  HsTyVar ("Zero", TcClsName)
+
+When the renamer hits this occurence of 'Zero' it's going to realise
+that it's not in scope. But because it is renaming a type, it knows
+that 'Zero' might be a promoted data constructor, so it will demote
+its namespace to DataName and do a second lookup.
+
+The final result (after the renamer) will be:
+  HsTyVar ("Zero", DataName)
+
 
 %************************************************************************
 %*                                                                     *
@@ -316,6 +344,13 @@ mkClsOcc = mkOccName clsName
 
 mkClsOccFS :: FastString -> OccName
 mkClsOccFS = mkOccNameFS clsName
+
+-- demoteOccName lowers the Namespace of OccName.
+-- see Note [Demotion]
+demoteOccName :: OccName -> Maybe OccName
+demoteOccName (OccName space name) = do
+  space' <- demoteNameSpace space
+  return $ OccName space' name
 \end{code}
 
 
index ba09d92..0353e65 100644 (file)
@@ -40,7 +40,7 @@ module RdrName (
        nameRdrName, getRdrName, 
 
        -- ** Destruction
-       rdrNameOcc, rdrNameSpace, setRdrNameSpace,
+       rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName,
        isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, 
        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
 
@@ -159,6 +159,14 @@ setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
 setRdrNameSpace (Exact n)    ns = ASSERT( isExternalName n ) 
                                  Orig (nameModule n)
                                       (setOccNameSpace ns (nameOccName n))
+
+-- demoteRdrName lowers the NameSpace of RdrName.
+-- see Note [Demotion] in OccName
+demoteRdrName :: RdrName -> Maybe RdrName
+demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)
+demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
+demoteRdrName (Orig _ _) = panic "demoteRdrName"
+demoteRdrName (Exact _) = panic "demoteRdrName"
 \end{code}
 
 \begin{code}
index a923f4d..1692520 100644 (file)
@@ -39,7 +39,7 @@
 
 module Var (
         -- * The main data type and synonyms
-        Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId,
+        Var, TyVar, CoVar, Id, KindVar, DictId, DFunId, EvVar, EqVar, EvId, IpId,
 
        -- ** Taking 'Var's apart
        varName, varUnique, varType, 
@@ -60,20 +60,21 @@ module Var (
        mustHaveLocalBinding,
 
        -- ** Constructing 'TyVar's
-       mkTyVar, mkTcTyVar, 
+       mkTyVar, mkTcTyVar, mkKindVar,
 
        -- ** Taking 'TyVar's apart
         tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
 
        -- ** Modifying 'TyVar's
-       setTyVarName, setTyVarUnique, setTyVarKind
+       setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,
+        updateTyVarKindM
 
     ) where
 
 #include "HsVersions.h"
 #include "Typeable.h"
 
-import {-# SOURCE #-}  TypeRep( Type, Kind )
+import {-# SOURCE #-}  TypeRep( Type, Kind, SuperKind )
 import {-# SOURCE #-}  TcType( TcTyVarDetails, pprTcTyVarDetails )
 import {-# SOURCE #-}  IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
 
@@ -98,7 +99,10 @@ import Data.Data
 
 \begin{code}
 type Id    = Var       -- A term-level identifier
-type TyVar = Var
+
+type TyVar   = Var     -- Type *or* kind variable
+type KindVar = Var     -- Definitely a kind variable
+                      -- See Note [Kind and type variables]
 
 -- See Note [Evidence: EvIds and CoVars]
 type EvId   = Id        -- Term-level evidence: DictId, IpId, or EqVar
@@ -125,6 +129,16 @@ Note [Evidence: EvIds and CoVars]
 * Only CoVars can occur in Coercions (but NB the LCoercion hack; see
   Note [LCoercions] in Coercion).
 
+Note [Kind and type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before kind polymorphism, TyVar were used to mean type variables. Now
+they are use to mean kind *or* type variables. KindVar is used when we
+know for sure that it is a kind variable. In future, we might want to
+go over the whole compiler code to use:
+   - KiTyVar to mean kind or type variables
+   - TyVar   to mean         type variables only
+   - KindVar to mean kind         variables
+
 
 %************************************************************************
 %*                                                                     *
@@ -142,7 +156,8 @@ in its @VarDetails@.
 -- | Essentially a typed 'Name', that may also contain some additional information
 -- about the 'Var' and it's use sites.
 data Var
-  = TyVar {
+  = TyVar {  -- type and kind variables
+             -- see Note [Kind and type variables]
        varName    :: !Name,
        realUnique :: FastInt,          -- Key for fast comparison
                                        -- Identical to the Unique in the name,
@@ -195,7 +210,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 
 \begin{code}
 instance Outputable Var where
-  ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
+  ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
+            <+> ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
 
 ppr_debug :: Var -> SDoc
 ppr_debug (TyVar {})                           = ptext (sLit "tv")
@@ -255,7 +271,7 @@ setVarType id ty = id { varType = ty }
 
 %************************************************************************
 %*                                                                     *
-\subsection{Type variables}
+\subsection{Type and kind variables}
 %*                                                                     *
 %************************************************************************
 
@@ -274,6 +290,14 @@ setTyVarName   = setVarName
 
 setTyVarKind :: TyVar -> Kind -> TyVar
 setTyVarKind tv k = tv {varType = k}
+
+updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar
+updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}
+
+updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar
+updateTyVarKindM update tv
+  = do { k' <- update (tyVarKind tv)
+       ; return $ tv {varType = k'} }
 \end{code}
 
 \begin{code}
@@ -298,6 +322,15 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
 
 setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
 setTcTyVarDetails tv details = tv { tc_tv_details = details }
+
+mkKindVar :: Name -> SuperKind -> KindVar
+-- mkKindVar take a SuperKind as argument because we don't have access
+-- to tySuperKind here.
+mkKindVar name kind = TyVar
+  { varName    = name
+  , realUnique = getKeyFastInt (nameUnique name)
+  , varType    = kind }
+
 \end{code}
 
 %************************************************************************
index 9351da1..1df8413 100644 (file)
@@ -218,11 +218,13 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 %************************************************************************
 
 \begin{code}
-type InType      = Type        -- Substitution not yet applied
+--type InKind      = Kind      -- Substitution not yet applied
+type InType      = Type        
 type InCoercion  = Coercion
 type InVar       = Var
 type InTyVar     = TyVar
 
+type OutKind     = Kind        -- Substitution has been applied to this
 type OutType     = Type        -- Substitution has been applied to this
 type OutCoercion = Coercion
 type OutVar      = Var
@@ -296,19 +298,6 @@ lintCoreExpr (Let (Rec pairs) body)
     (_, dups) = removeDups compare bndrs
 
 lintCoreExpr e@(App _ _)
-    | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
-                   -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
-                   -- we should do this properly
-    , Just dc <- isDataConWorkId_maybe x
-    , dc == eqBoxDataCon
-    , [Type arg_ty1, Type arg_ty2, co_e] <- args
-    = do arg_kind1 <- lintType arg_ty1
-         arg_kind2 <- lintType arg_ty2
-         unless (arg_kind1 `eqKind` arg_kind2)
-                (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
-         
-         lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e
-    | otherwise
     = do { fun_ty <- lintCoreExpr fun
          ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
   where
@@ -370,6 +359,27 @@ lintCoreExpr (Coercion co)
        ; return (mkCoercionType ty1 ty2) }
 \end{code}
 
+Note [Kind instantiation in coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider the following coercion axiom:
+  ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa
+
+Consider the following instantiation:
+  ax_co <* -> *> <Monad>
+
+We need to split the co_ax_tvs into kind and type variables in order
+to find out the coercion kind instantiations. Those can only be Refl
+since we don't have kind coercions. This is just a way to represent
+kind instantiation.
+
+We use the number of kind variables to know how to split the coercions
+instantiations between kind coercions and type coercions. We lint the
+kind coercions and produce the following substitution which is to be
+applied in the type variables:
+  k_ag   ~~>   * -> *
+
+
 %************************************************************************
 %*                                                                     *
 \subsection[lintCoreArgs]{lintCoreArgs}
@@ -432,10 +442,14 @@ lintValApp arg fun_ty arg_ty
 checkTyKind :: OutTyVar -> OutType -> LintM ()
 -- Both args have had substitution applied
 checkTyKind tyvar arg_ty
+  | isSuperKind tyvar_kind  -- kind forall
+  -- IA0_NOTE: I added this case to handle kind foralls
+  = lintKind arg_ty
        -- Arg type might be boxed for a function with an uncommitted
        -- tyvar; notably this is used so that we can give
        --      error :: forall a:*. String -> a
        -- and then apply it to both boxed and unboxed types.
+  | otherwise  -- type forall
   = do { arg_kind <- lintType arg_ty
        ; unless (arg_kind `isSubKind` tyvar_kind)
                 (addErrL (mkKindErrMsg tyvar arg_ty)) }
@@ -458,6 +472,16 @@ checkTyCoKind tv co
 checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
 checkTyCoKinds = zipWithM checkTyCoKind
 
+checkKiCoKind :: KindVar -> OutCoercion -> LintM Kind
+-- see lintCoercion (AxiomInstCo {}) and Note [Kind instantiation in coercions]
+checkKiCoKind kv co
+  = do { ki <- lintKindCoercion co
+       ; unless (isSuperKind (tyVarKind kv)) (addErrL (mkTyCoAppErrMsg kv co))
+       ; return ki }
+
+checkKiCoKinds :: [KindVar] -> [OutCoercion] -> LintM [Kind]
+checkKiCoKinds = zipWithM checkKiCoKind
+
 checkDeadIdOcc :: Id -> LintM ()
 -- Occurrences of an Id should never be dead....
 -- except when we are checking a case pattern
@@ -622,11 +646,11 @@ lintAndScopeId id linterF
 lintInTy :: InType -> LintM OutType
 -- Check the type, and apply the substitution to it
 -- See Note [Linting type lets]
--- ToDo: check the kind structure of the type
 lintInTy ty 
   = addLoc (InType ty) $
     do { ty' <- applySubstTy ty
-       ; _ <- lintType ty'
+       ; k <- lintType ty'
+       ; lintKind k
        ; return ty' }
 
 lintInCo :: InCoercion -> LintM OutCoercion
@@ -639,21 +663,42 @@ lintInCo co
         ; return co' }
 
 -------------------
-lintKind :: Kind -> LintM ()
--- Check well-formedness of kinds: *, *->*, etc
-lintKind (TyConApp tc []) 
-  | tyConKind tc `eqKind` tySuperKind
-  = return ()
+lintKind :: OutKind -> LintM ()
+-- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc
 lintKind (FunTy k1 k2)
   = lintKind k1 >> lintKind k2
-lintKind kind 
+
+lintKind kind@(TyConApp tc kis)
+  = do { unless (tyConArity tc == length kis || isSuperKindTyCon tc)
+           (addErrL malformed_kind)
+       ; mapM_ lintKind kis }
+  where
+    malformed_kind = hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))
+
+lintKind (TyVarTy kv) = checkTyCoVarInScope kv
+lintKind kind
   = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)))
 
 -------------------
 lintTyBndrKind :: OutTyVar -> LintM ()
-lintTyBndrKind tv = lintKind (tyVarKind tv)
+-- Handles both type and kind foralls.
+lintTyBndrKind tv =
+  let ki = tyVarKind tv in
+  if isSuperKind ki
+  then return ()    -- kind forall
+  else lintKind ki  -- type forall
 
 -------------------
+lintKindCoercion :: OutCoercion -> LintM OutKind
+-- Kind coercions are only reflexivity because they mean kind
+-- instantiation.  See Note [Kind coercions] in Coercion
+lintKindCoercion co
+  = do { (k1,k2) <- lintCoercion co
+       ; checkL (k1 `eqKind` k2) 
+                (hang (ptext (sLit "Non-refl kind coercion")) 
+                    2 (ppr co))
+       ; return k1 }
+
 lintCoercion :: OutCoercion -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
 lintCoercion (Refl ty)
@@ -661,9 +706,21 @@ lintCoercion (Refl ty)
        ; return (ty, ty) }
 
 lintCoercion co@(TyConAppCo tc cos)
-  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
-       ; check_co_app co (tyConKind tc) ss
-       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
+  = do   -- We use the kind of the type constructor to know how many
+         -- kind coercions we have (one kind coercion for one kind
+         -- instantiation).
+       { let ki | tc `hasKey` funTyConKey && length cos == 2
+                  = mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind
+                  -- It's a fully applied function, so we must use the
+                  -- most permissive type for the arrow constructor
+                | otherwise = tyConKind tc
+             (kvs, _) = splitForAllTys ki
+             (cokis, cotys) = splitAt (length kvs) cos
+         -- kis are the kind instantiations of tc
+       ; kis <- mapM lintKindCoercion cokis
+       ; (ss,ts) <- mapAndUnzipM lintCoercion cotys
+       ; check_co_app co ki (kis ++ ss)
+       ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) }
 
 lintCoercion co@(AppCo co1 co2)
   = do { (s1,t1) <- lintCoercion co1
@@ -672,7 +729,9 @@ lintCoercion co@(AppCo co1 co2)
        ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
 
 lintCoercion (ForAllCo v co)
-  = do { lintKind (tyVarKind v)
+  = do { let kind = tyVarKind v
+         -- lintKind when type forall, otherwise we are a kind forall
+       ; unless (isSuperKind kind) (lintKind kind)
        ; (s,t) <- addInScopeVar v (lintCoercion co)
        ; return (ForAllTy v s, ForAllTy v t) }
 
@@ -684,13 +743,21 @@ lintCoercion (CoVarCo cv)
   = do { checkTyCoVarInScope cv
        ; return (coVarKind cv) }
 
-lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
+lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
                                    , co_ax_lhs = lhs
-                                   , co_ax_rhs = rhs }) 
+                                   , co_ax_rhs = rhs })
                            cos)
-  = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
-       ; return (substTyWith tvs tys1 lhs,
-                 substTyWith tvs tys2 rhs) }
+  = ASSERT2 (not (any isKiVar tvs), ppr ktvs)
+    do   -- see Note [Kind instantiation in coercions]
+       { kis <- checkKiCoKinds kvs kcos
+       ; let tvs' = map (updateTyVarKind (Type.substTy subst)) tvs
+             subst = zipOpenTvSubst kvs kis
+       ; (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs' tcos)
+       ; return (substTyWith ktvs (kis ++ tys1) lhs,
+                 substTyWith ktvs (kis ++ tys2) rhs) }
+  where
+    (kvs, tvs) = splitKiTyVars ktvs
+    (kcos, tcos) = splitAt (length kvs) cos
 
 lintCoercion (UnsafeCo ty1 ty2)
   = do { _k1 <- lintType ty1
@@ -741,20 +808,21 @@ checkTcApp co n ty
 lintType :: OutType -> LintM Kind
 lintType (TyVarTy tv)
   = do { checkTyCoVarInScope tv
-       ; return (tyVarKind tv) }
+       ; let kind = tyVarKind tv
+       ; lintKind kind
+       ; if (isSuperKind kind) then failWithL msg
+         else return kind }
+  where msg = hang (ptext (sLit "Expecting a type, but got a kind"))
+                 2 (ptext (sLit "Offending kind:") <+> ppr tv)
 
 lintType ty@(AppTy t1 t2) 
   = do { k1 <- lintType t1
        ; lint_ty_app ty k1 [t2] }
 
 lintType ty@(FunTy t1 t2)
-  = lint_ty_app ty (tyConKind funTyCon) [t1,t2]
+  = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2]
 
 lintType ty@(TyConApp tc tys)
-  | tc `hasKey` eqPrimTyConKey -- See Note [The ~# TyCon] in TysPrim
-  = lint_prim_eq_pred ty tys
-  | tc `hasKey` eqTyConKey
-  = lint_eq_pred ty tys
   | tyConHasKind tc
   = lint_ty_app ty (tyConKind tc) tys
   | otherwise
@@ -766,58 +834,43 @@ lintType (ForAllTy tv ty)
 
 ----------------
 lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
-lint_ty_app ty k tys 
-  = do { ks <- mapM lintType tys
-       ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
-
-lint_eq_pred :: Type -> [OutType] -> LintM Kind
-lint_eq_pred ty arg_tys = case arg_tys of
-  [ty1, ty2] ->  do { k1 <- lintType ty1
-                    ; k2 <- lintType ty2
-                    ; unless (k1 `eqKind` k2) 
-                             (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
-                                           , nest 2 (ppr ty) ]))
-                    ; return constraintKind }
-  [ty1] -> do { k1 <- lintType ty1;
-                return (k1 `mkFunTy` constraintKind) }
-  []    -> do { return (typeKind ty) }
-  _     -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty)
-
-
-lint_prim_eq_pred :: Type -> [OutType] -> LintM Kind
-lint_prim_eq_pred ty arg_tys
-  | [ty1,ty2] <- arg_tys
-  = do { k1 <- lintType ty1
-       ; k2 <- lintType ty2
-       ; checkL (k1 `eqKind` k2) 
-                (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
-       ; return unliftedTypeKind }
-  | otherwise
-  = failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty)
+lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
 
 ----------------
 check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
-check_co_app ty k tys 
-  = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty))  
-                            k (map typeKind tys)
-       ; return () }
-                      
+check_co_app ty k tys = lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys >> return ()
+
 ----------------
-lint_kind_app :: SDoc -> Kind -> [Kind] -> LintM Kind
-lint_kind_app doc kfn ks = go kfn ks
+lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind
+-- Takes care of linting the OutTypes
+lint_kind_app doc kfn tys = go kfn tys
   where
-    fail_msg = vcat [hang (ptext (sLit "Kind application error in")) 2 doc,
-                            nest 2 (ptext (sLit "Function kind =") <+> ppr kfn),
-                            nest 2 (ptext (sLit "Arg kinds =") <+> ppr ks)]
-
-    go kfn []     = return kfn
-    go kfn (k:ks) = case splitKindFunTy_maybe kfn of
-                             Nothing         -> failWithL fail_msg
-                     Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
-                                                     (addErrL fail_msg)
-                                            ; go kfb ks } 
+    fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc
+                    , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn)
+                    , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ]
+
+    go kfn [] = return kfn
+    go kfn (ty:tys) =
+      case splitKindFunTy_maybe kfn of
+      { Nothing ->
+          case splitForAllTy_maybe kfn of
+          { Nothing -> failWithL fail_msg
+          ; Just (kv, body) -> do
+              -- Something of kind (forall kv. body) gets instantiated
+              -- with ty. 'kv' is a kind variable and 'ty' is a kind.
+            { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg)
+            ; lintKind ty
+            ; go (substKiWith [kv] [ty] body) tys } }
+      ; Just (kfa, kfb) -> do
+          -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is
+          -- a type accepting kind 'kfa'.
+        { k <- lintType ty
+        ; lintKind kfa
+        ; unless (k `isSubKind` kfa) (addErrL fail_msg)
+        ; go kfb tys } }
+
 \end{code}
-    
+
 %************************************************************************
 %*                                                                     *
 \subsection[lint-monad]{The Lint monad}
@@ -1168,14 +1221,6 @@ mkStrictMsg binder
             ]
 
 
-mkEqBoxKindErrMsg :: Type -> Type -> Message
-mkEqBoxKindErrMsg ty1 ty2
-  = vcat [ptext (sLit "Kinds don't match in type arguments of Eq#:"),
-          hang (ptext (sLit "Arg type 1:"))   
-                 4 (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)),
-          hang (ptext (sLit "Arg type 2:"))   
-                 4 (ppr ty2 <+> dcolon <+> ppr (typeKind ty2))]
-
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext (sLit "Kinds don't match in type application:"),
index 6bcf3fb..c4b3019 100644 (file)
@@ -67,6 +67,7 @@ import Util
 import Pair
 import Data.Word
 import Data.Bits
+import Data.List ( mapAccumL )
 \end{code}
 
 
@@ -1064,9 +1065,10 @@ dataConInstPat :: [FastString]          -- A long enough list of FSs to use for
 --
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
-dataConInstPat fss uniqs con inst_tys
-  = (ex_bndrs, arg_ids)
-  where
+dataConInstPat fss uniqs con inst_tys 
+  = ASSERT( univ_tvs `equalLength` inst_tys )
+    (ex_bndrs, arg_ids)
+  where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
     arg_tys  = dataConRepArgTys con
@@ -1077,19 +1079,25 @@ dataConInstPat fss uniqs con inst_tys
     (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
     (ex_fss,   id_fss)   = splitAt n_ex fss
 
-      -- Make existential type variables
-    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
-    mk_ex_var uniq fs var = mkTyVar new_name kind
+      -- Make the instantiating substitution for universals
+    univ_subst = zipOpenTvSubst univ_tvs inst_tys
+
+      -- Make existential type variables, applyingn and extending the substitution
+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst 
+                                       (zip3 ex_tvs ex_fss ex_uniqs)
+
+    mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar)
+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv)
+                                     , new_tv)
       where
+        new_tv   = mkTyVar new_name kind
         new_name = mkSysTvName uniq fs
-        kind     = tyVarKind var
-
-      -- Make the instantiating substitution
-    subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
+        kind     = Type.substTy subst (tyVarKind tv)
 
       -- Make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
     arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq 
+                                       (Type.substTy full_subst ty) noSrcSpan
 \end{code}
 
 %************************************************************************
index d941b0a..dd41184 100644 (file)
@@ -288,8 +288,10 @@ mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty]
 \begin{code}
 
 mkEqBox :: Coercion -> CoreExpr
-mkEqBox co = Var (dataConWorkId eqBoxDataCon) `mkTyApps` [ty1, ty2] `App` Coercion co
+mkEqBox co = ASSERT( typeKind ty2 `eqKind` k )
+             Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co
   where Pair ty1 ty2 = coercionKind co
+        k = typeKind ty1
 
 \end{code}
 
index e38885b..cb12973 100644 (file)
@@ -23,6 +23,7 @@ import TyCon
 -- import Class
 import TypeRep
 import Type
+import Kind
 import PprExternalCore () -- Instances
 import DataCon
 import Coercion
index 2ba8a23..c575b68 100644 (file)
@@ -28,6 +28,7 @@ import Demand
 import DataCon
 import TyCon
 import Type
+import Kind
 import Coercion
 import StaticFlags
 import BasicTypes
index 2e721ad..a9701ff 100644 (file)
@@ -86,7 +86,6 @@ deSugar hsc_env
                             tcg_rules        = rules,
                             tcg_vects        = vects,
                             tcg_tcs          = tcs,
-                            tcg_clss         = clss,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
                             tcg_hpc          = other_hpc_info })
@@ -184,7 +183,6 @@ deSugar hsc_env
                 mg_warns        = warns,
                 mg_anns         = anns,
                 mg_tcs          = tcs,
-                mg_clss         = clss,
                 mg_insts        = insts,
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
index 628f911..4b710f6 100644 (file)
@@ -53,6 +53,7 @@ import NameEnv
 import TcType
 import TyCon
 import TysWiredIn
+import TysPrim ( liftedTypeKindTyConName )
 import CoreSyn
 import MkCore
 import CoreUtils
@@ -81,7 +82,7 @@ dsBracket brack splices
   where
     new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
 
-    do_brack (VarBr n)   = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
     do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
     do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
     do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
@@ -598,7 +599,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm
   = repKind ki >>= repKindedTV nm
 
 -- represent a type context
@@ -684,7 +685,7 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
-repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
+repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
                                   `nlHsAppTy` ty2)
 repTy (HsParTy t)          = repLTy t
 repTy (HsKindSig t k)       = do
@@ -696,17 +697,16 @@ repTy ty                = notHandled "Exotic form of type" (ppr ty)
 
 -- represent a kind
 --
-repKind :: Kind -> DsM (Core TH.Kind)
+repKind :: LHsKind Name -> DsM (Core TH.Kind)
 repKind ki
-  = do { let (kis, ki') = splitKindFunTys ki
+  = do { let (kis, ki') = splitHsFunType ki
        ; kis_rep <- mapM repKind kis
        ; ki'_rep <- repNonArrowKind ki'
        ; foldrM repArrowK ki'_rep kis_rep
        }
   where
-    repNonArrowKind k | isLiftedTypeKind k = repStarK
-                      | otherwise          = notHandled "Exotic form of kind" 
-                                                        (ppr k)
+    repNonArrowKind (L _ (HsTyVar name)) | name == liftedTypeKindTyConName = repStarK
+    repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
 
 -----------------------------------------------------------------------------
 --             Splices
index 84d0acf..f521ee6 100644 (file)
@@ -45,6 +45,7 @@ import Var
 import TcRnMonad
 import TcType
 import TcMType
+import TcHsSyn ( mkZonkTcTyVar )
 import TcUnify
 import TcEnv
 
@@ -1130,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM
 zonkRttiType :: TcType -> TcM Type
 -- Zonk the type, replacing any unbound Meta tyvars
 -- by skolems, safely out of Meta-tyvar-land
-zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta
+zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy)
   where
     zonk_unbound_meta tv 
       = ASSERT( isTcTyVar tv )
index fc33dc1..6f88319 100644 (file)
@@ -27,7 +27,6 @@ import qualified OccName
 import OccName
 import SrcLoc
 import Type
-import Coercion
 import TysWiredIn
 import BasicTypes as Hs
 import ForeignCall
@@ -204,7 +203,7 @@ cvtDec (ForeignD ford)
 
 cvtDec (FamilyD flav tc tvs kind)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
-       ; let kind' = fmap cvtKind kind
+       ; kind' <- cvtMaybeKind kind
        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
   where
     cvtFamFlavour TypeFam = TypeFamily
@@ -785,7 +784,8 @@ cvt_tv (TH.PlainTV nm)
        }
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
-       ; returnL $ KindedTyVar nm' (cvtKind ki)
+       ; ki' <- cvtKind ki
+       ; returnL $ KindedTyVar nm' ki' placeHolderKind
        }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
@@ -842,7 +842,8 @@ cvtType ty
 
            SigT ty ki
              -> do { ty' <- cvtType ty
-                   ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
+                   ; ki' <- cvtKind ki
+                   ; mk_apps (HsKindSig ty' ki') tys'
                    }
 
            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
@@ -859,9 +860,16 @@ split_ty_app ty = go ty []
     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
     go f as          = return (f,as)
 
-cvtKind :: TH.Kind -> Type.Kind
-cvtKind StarK          = liftedTypeKind
-cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
+cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
+cvtKind StarK          = returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
+cvtKind (ArrowK k1 k2) = do
+  k1' <- cvtKind k1
+  k2' <- cvtKind k2
+  returnL (HsFunTy k1' k2')
+
+cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
+cvtMaybeKind Nothing = return Nothing
+cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just
 
 -----------------------------------------------------------
 
index 9cdc47d..c372878 100644 (file)
@@ -23,6 +23,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
 
+import HsLit
 import HsTypes
 import PprCore ()
 import CoreSyn
@@ -461,9 +462,9 @@ data HsWrapper
   | WpEvLam EvVar               -- \d. []       the 'd' is an evidence variable
   | WpEvApp EvTerm              -- [] d         the 'd' is evidence for a constraint
 
-        -- Type abstraction and application
-  | WpTyLam TyVar               -- \a. []       the 'a' is a type variable (not coercion var)
-  | WpTyApp Type                -- [] t         the 't' is a type (not coercion)
+       -- Kind and Type abstraction and application
+  | WpTyLam TyVar      -- \a. []       the 'a' is a type/kind variable (not coercion var)
+  | WpTyApp KindOrType -- [] t         the 't' is a type (not coercion)
 
 
   | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,
index 480401b..ea34e79 100644 (file)
@@ -14,7 +14,7 @@ module HsDecls (
   -- * Toplevel declarations
   HsDecl(..), LHsDecl,
   -- ** Class or type declarations
-  TyClDecl(..), LTyClDecl,
+  TyClDecl(..), LTyClDecl, TyClGroup,
   isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
   isFamInstDecl, tcdName, tyClDeclTyVars,
   countTyClDecls,
@@ -63,7 +63,6 @@ import HsDoc
 import TyCon
 import NameSet
 import Name
-import {- Kind parts of -} Type
 import BasicTypes
 import Coercion
 import ForeignCall
@@ -431,6 +430,8 @@ Interface file code:
 -- In both cases, 'tcdVars' collects all variables we need to quantify over.
 
 type LTyClDecl name = Located (TyClDecl name)
+type TyClGroup name = [LTyClDecl name]  -- this is used in TcTyClsDecls to represent
+                                        -- strongly connected components of decls
 
 -- | A type or class declaration.
 data TyClDecl name
@@ -444,7 +445,7 @@ data TyClDecl name
     TyFamily {  tcdFlavour:: FamilyFlavour,             -- type or data
                 tcdLName  :: Located name,              -- type constructor
                 tcdTyVars :: [LHsTyVarBndr name],       -- type variables
-                tcdKind   :: Maybe Kind                 -- result kind
+                tcdKind   :: Maybe (LHsKind name)       -- result kind
     }
 
 
@@ -461,7 +462,7 @@ data TyClDecl name
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
                   -- See Note [tcdTyVars and tcdTyPats] 
 
-                tcdKindSig:: Maybe Kind,
+                tcdKindSig:: Maybe (LHsKind name),
                         -- ^ Optional kind signature.
                         --
                         -- @(Just k)@ for a GADT-style @data@, or @data
@@ -535,14 +536,18 @@ tcdTyPats = Just tys
    This is a data/type family instance declaration
    tcdTyVars are fv(tys)
 
-   Eg   class C a b where
-          type F a x :: *
-        instance D p s => C (p,q) [r] where
-          type F (p,q) x = p -> x
-   The tcdTyVars of the F instance decl are {p,q,x},
-   i.e. not including s, nor r 
-        (and indeed neither s nor should be mentioned
-         on the RHS of the F instance decl; Trac #5515)
+   Eg   class C s t where
+          type F t p :: *
+        instance C w (a,b) where
+          type F (a,b) x = x->a
+   The tcdTyVars of the F decl are {a,b,x}, even though the F decl
+   is nested inside the 'instance' decl. 
+
+   However after the renamer, the uniques will match up:
+        instance C w7 (a8,b9) where
+          type F (a8,b9) x10 = x10->a8
+   so that we can compare the type patter in the 'instance' decl and
+   in the associated 'type' decl
 
 ------------------------------
 Simple classifiers
@@ -631,7 +636,7 @@ instance OutputableBndr name
 
           pp_kind = case mb_kind of
                       Nothing   -> empty
-                      Just kind -> dcolon <+> pprKind kind
+                      Just kind -> dcolon <+> ppr kind
 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
                     tcdSynRhs = mono_ty})
@@ -653,7 +658,7 @@ instance OutputableBndr name
                   derivings
       where
         ppr_sigx Nothing     = empty
-        ppr_sigx (Just kind) = dcolon <+> pprKind kind
+        ppr_sigx (Just kind) = dcolon <+> ppr kind
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,
index 869532e..7b814e1 100644 (file)
@@ -1197,7 +1197,8 @@ data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | DecBrL [LHsDecl id]         -- [d| decls |]; result of parser
                   | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer
                   | TypBr (LHsType id)   -- [t| type  |]
-                  | VarBr id             -- 'x, ''T
+                  | VarBr Bool id        -- True: 'x, False: ''T
+                                         -- (The Bool flag is used only in pprHsBracket)
   deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsBracket id) where
@@ -1210,11 +1211,8 @@ pprHsBracket (PatBr p)    = thBrackets (char 'p') (ppr p)
 pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
 pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
 pprHsBracket (TypBr t)          = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr n)          = char '\'' <> ppr n
--- Infelicity: can't show ' vs '', because
--- we can't ask n what its OccName is, because the
--- pretty-printer for HsExpr doesn't ask for NamedThings
--- But the pretty-printer for names will show the OccName class
+pprHsBracket (VarBr True n)  = char '\''         <> ppr n
+pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
index 4dff75c..6666243 100644 (file)
@@ -1,4 +1,5 @@
 \begin{code}
+{-# LANGUAGE KindSignatures #-}
 {-# OPTIONS -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
@@ -13,11 +14,12 @@ import Outputable ( SDoc, OutputableBndr )
 import {-# SOURCE #-} HsPat  ( LPat )
 
 import Data.Data
-       
-data HsExpr i
-data HsSplice i
-data MatchGroup a
-data GRHSs a
+
+-- IA0_NOTE: We need kind annotations because of kind polymorphism
+data HsExpr (i :: *)
+data HsSplice (i :: *)
+data MatchGroup (a :: *)
+data GRHSs (a :: *)
 
 instance Typeable1 HsSplice
 instance Data i => Data (HsSplice i)
index b8e4b11..efa61dd 100644 (file)
@@ -20,8 +20,7 @@ module HsLit where
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
 import BasicTypes ( FractionalLit(..) )
-import HsTypes  ( PostTcType )
-import Type    ( Type )
+import Type    ( Type, Kind )
 import Outputable
 import FastString
 
@@ -31,6 +30,26 @@ import Data.Data
 
 %************************************************************************
 %*                                                                     *
+\subsection{Annotating the syntax}
+%*                                                                     *
+%************************************************************************
+
+\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
+                               -- before typechecking it's just bogus
+
+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}
+
+%************************************************************************
+%*                                                                     *
 \subsection[HsLit]{Literals}
 %*                                                                     *
 %************************************************************************
index 7ba338e..2899103 100644 (file)
@@ -1,10 +1,13 @@
 \begin{code}
+{-# LANGUAGE KindSignatures #-}
+
 module HsPat where
 import SrcLoc( Located )
 
 import Data.Data
 
-data Pat i
+-- IA0_NOTE: We need kind annotation because of kind polymorphism.
+data Pat (i :: *)
 type LPat i = Located (Pat i)
 
 instance Typeable1 Pat
index 9e20dbd..fec71af 100644 (file)
@@ -16,11 +16,12 @@ HsTypes: Abstract syntax: user-defined types
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module HsTypes (
-       HsType(..), LHsType, 
+       HsType(..), LHsType, HsKind, LHsKind,
        HsTyVarBndr(..), LHsTyVarBndr,
        HsTupleSort(..), HsExplicitFlag(..),
        HsContext, LHsContext,
        HsQuasiQuote(..),
+        HsTyWrapper(..),
 
        LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
@@ -29,16 +30,13 @@ module HsTypes (
        
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
        hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
-       hsTyVarKind, hsTyVarNameKind,
+       hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
         splitHsForAllTy, splitLHsForAllTy,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
-       splitHsAppTys, mkHsAppTys,
-       
-       -- Type place holder
-       PostTcType, placeHolderType, PostTcKind, placeHolderKind,
+       splitHsAppTys, mkHsAppTys, mkHsOpTy,
 
        -- Printing
        pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
@@ -46,7 +44,9 @@ module HsTypes (
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import NameSet ( FreeVars )
+import HsLit
+
+import NameSet( FreeVars )
 import Type
 import HsDoc
 import BasicTypes
@@ -61,26 +61,6 @@ import Data.Data
 
 %************************************************************************
 %*                                                                     *
-\subsection{Annotating the syntax}
-%*                                                                     *
-%************************************************************************
-
-\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
-                               -- before typechecking it's just bogus
-
-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}
-
-%************************************************************************
-%*                                                                     *
        Quasi quotes; used in types and elsewhere
 %*                                                                     *
 %************************************************************************
@@ -136,6 +116,8 @@ type LHsContext name = Located (HsContext name)
 type HsContext name = [LHsType name]
 
 type LHsType name = Located (HsType name)
+type HsKind name = HsType name
+type LHsKind name = Located (HsKind name)
 
 data HsType name
   = HsForAllTy HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
@@ -146,7 +128,8 @@ data HsType name
                (LHsContext name)
                (LHsType name)
 
-  | HsTyVar            name            -- Type variable or type constructor
+  | HsTyVar            name            -- Type variable, type constructor, or data constructor
+                                        -- see Note [Promotions (HsTyVar)]
 
   | HsAppTy            (LHsType name)
                        (LHsType name)
@@ -161,7 +144,7 @@ data HsType name
   | HsTupleTy          HsTupleSort
                        [LHsType name]  -- Element types (length gives arity)
 
-  | HsOpTy             (LHsType name) (Located name) (LHsType name)
+  | HsOpTy             (LHsType name) (LHsTyOp name) (LHsType name)
 
   | HsParTy            (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
        -- Parenthesis preserved for the precedence re-arrangement in RnTypes
@@ -174,7 +157,7 @@ data HsType name
                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
 
   | HsKindSig          (LHsType name)  -- (ty :: kind)
-                       Kind            -- A type with a kind signature
+                       (LHsKind name)  -- A type with a kind signature
 
   | HsQuasiQuoteTy     (HsQuasiQuote name)
 
@@ -189,11 +172,69 @@ data HsType name
 
   | HsCoreTy Type      -- An escape hatch for tunnelling a *closed* 
                        -- Core Type through HsSyn.  
-                                        
+
+  | HsExplicitListTy     -- A promoted explicit list
+        PostTcKind       -- See Note [Promoted lists and tuples]
+        [LHsType name]   
+                         
+  | HsExplicitTupleTy    -- A promoted explicit tuple
+        [PostTcKind]     -- See Note [Promoted lists and tuples]
+        [LHsType name]   
+
+  | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
+  deriving (Data, Typeable)
+
+data HsTyWrapper
+  = WpKiApps [Kind]  -- kind instantiation: [] k1 k2 .. kn
   deriving (Data, Typeable)
 
+type LHsTyOp name = HsTyOp (Located name)
+type HsTyOp name = (HsTyWrapper, name)
+
+mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
+mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
+\end{code}
+
+Note [Promotions (HsTyVar)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+HsTyVar: A name in a type or kind.
+  Here are the allowed namespaces for the name.
+    In a type:
+      Var: not allowed
+      Data: promoted data constructor
+      Tv: type variable
+      TcCls before renamer: type constructor, class constructor, or promoted data constructor
+      TcCls after renamer: type constructor or class constructor
+    In a kind:
+      Var, Data: not allowed
+      Tv: kind variable
+      TcCls: kind constructor or promoted type constructor
+
+
+Note [Promoted lists and tuples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice the difference between
+   HsListTy    HsExplicitListTy
+   HsTupleTy   HsExplicitListTupleTy
+
+E.g.    f :: [Int]                      HsListTy                
+
+        g3  :: T '[]                   All these use  
+        g2  :: T '[True]                  HsExplicitListTy        
+        g1  :: T '[True,False]          
+        g1a :: T [True,False]             (can omit ' where unambiguous)
+
+  kind of T :: [Bool] -> *        This kind uses HsListTy!
+
+E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair               
+        k :: S '(True,False)            HsExplicitTypleTy; S is indexed by   
+                                           a type-level pair of booleans 
+        kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy
+
+
+\begin{code}
 data HsTupleSort = HsUnboxedTuple
-                 | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking
+                 | HsBoxyTuple PostTcKind -- Either a Constraint or normal tuple: resolved during type checking
                  deriving (Data, Typeable)
 
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
@@ -252,9 +293,10 @@ data HsTyVarBndr name
          name          -- See Note [Printing KindedTyVars]
          PostTcKind
 
-  | KindedTyVar 
-         name 
-         Kind 
+  | KindedTyVar
+         name
+         (LHsKind name)        -- The user-supplied kind signature
+         PostTcKind
       --  *** NOTA BENE *** A "monotype" in a pragma can have
       -- for-alls in it, (mostly to do with dictionaries).  These
       -- must be explicitly Kinded.
@@ -262,15 +304,18 @@ data HsTyVarBndr name
 
 hsTyVarName :: HsTyVarBndr name -> name
 hsTyVarName (UserTyVar n _)   = n
-hsTyVarName (KindedTyVar n _) = n
+hsTyVarName (KindedTyVar n _ _) = n
 
 hsTyVarKind :: HsTyVarBndr name -> Kind
 hsTyVarKind (UserTyVar _ k)   = k
-hsTyVarKind (KindedTyVar _ 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)
+hsTyVarNameKind (KindedTyVar n k) = (n,k)
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -287,12 +332,18 @@ hsLTyVarLocName = fmap hsTyVarName
 hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
 hsLTyVarLocNames = map hsLTyVarLocName
 
-replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
-replaceTyVarName (UserTyVar _ k)   n' = UserTyVar n' k
-replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
-
-replaceLTyVarName :: LHsTyVarBndr name1 -> name2 -> LHsTyVarBndr name2
-replaceLTyVarName (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
+replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2  -- new type name
+                    -> (LHsKind name1 -> m (LHsKind name2))  -- kind renaming
+                    -> m (HsTyVarBndr name2)
+replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k
+replaceTyVarName (KindedTyVar _ k tck) n' rn = do
+  k' <- rn k
+  return $ KindedTyVar n' k' tck
+
+replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2
+                  -> (LHsKind name1 -> m (LHsKind name2))
+                  -> m (LHsTyVarBndr name2)
+replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc
 \end{code}
 
 
@@ -351,12 +402,12 @@ splitLHsClassTy_maybe ty
   = checkl ty []
   where
     checkl (L l ty) args = case ty of
-        HsTyVar t      -> Just (L l t, args)
-        HsAppTy l r    -> checkl l (r:args)
-        HsOpTy l tc r  -> checkl (fmap HsTyVar tc) (l:r:args)
-        HsParTy t      -> checkl t args
-        HsKindSig ty _ -> checkl ty args
-        _              -> Nothing
+        HsTyVar t          -> Just (L l t, args)
+        HsAppTy l r        -> checkl l (r:args)
+        HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args)
+        HsParTy t          -> checkl t args
+        HsKindSig ty _     -> checkl ty args
+        _                  -> Nothing
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
@@ -380,9 +431,9 @@ splitHsFunType other                   = ([], other)
 instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
-instance (Outputable name) => Outputable (HsTyVarBndr name) where
+instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name _)      = ppr name
-    ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind]
+    ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind]
 
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
 pprHsForAll exp tvs cxt 
@@ -470,12 +521,28 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
   where std_con = case con of
                     HsUnboxedTuple -> UnboxedTuple
                     HsBoxyTuple _  -> BoxedTuple
-ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
+ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
 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 prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
+ppr_mono_ty _    (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
+ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
+
+ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
+  = ppr_mono_ty ctxt_prec ty
+-- We are not printing kind applications. If we wanted to do so, we should do
+-- something like this:
+{-
+  = go ctxt_prec kis ty
+  where
+    go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty
+    go ctxt_prec (ki:kis) ty
+      = maybeParen ctxt_prec pREC_CON $
+        hsep [ go pREC_FUN kis ty
+             , ptext (sLit "@") <> pprParendKind ki ]
+-}
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
   = maybeParen ctxt_prec pREC_OP $
@@ -485,9 +552,9 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)  
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (wrapper, op) ty2)
   = maybeParen ctxt_prec pREC_OP $
-    ppr_mono_lty pREC_OP ty1 <+> ppr op <+> ppr_mono_lty pREC_OP ty2
+    ppr_mono_lty pREC_OP ty1 <+> ppr_mono_ty pREC_CON (HsWrapTy wrapper (HsTyVar (unLoc op))) <+> ppr_mono_lty pREC_OP ty2
 
 ppr_mono_ty _         (HsParTy ty)
   = parens (ppr_mono_lty pREC_TOP ty)
index 394e93d..eb6ca87 100644 (file)
@@ -1006,11 +1006,31 @@ instance Binary IfaceType where
             put_ bh ah
     
         -- Simple compression for common cases of TyConApp
-    put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 4; put_ bh k }
-    put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 5; put_ bh tc; put_ bh tys }
-    put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 6; put_ bh tc; put_ bh tys }
-
-    put_ bh (IfaceCoConApp cc tys) = do { putByte bh 7; put_ bh cc; put_ bh tys }
+    put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
+    put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
+    put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
+    put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
+        -- Unit tuple and pairs
+    put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10
+    put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2])
+      = do { putByte bh 11; put_ bh t1; put_ bh t2 }
+        -- Kind cases
+    put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
+    put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
+    put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
+    put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
+    put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
+    put_ bh (IfaceTyConApp IfaceConstraintKindTc [])   = putByte bh 17
+    put_ bh (IfaceTyConApp IfaceSuperKindTc [])        = putByte bh 18
+
+    put_ bh (IfaceCoConApp cc tys)
+      = do { putByte bh 19; put_ bh cc; put_ bh tys }
+
+        -- Generic cases
+    put_ bh (IfaceTyConApp (IfaceTc tc) tys)
+      = do { putByte bh 20; put_ bh tc; put_ bh tys }
+    put_ bh (IfaceTyConApp tc tys)
+      = do { putByte bh 21; put_ bh tc; put_ bh tys }
 
     get bh = do
             h <- getByte bh
@@ -1026,20 +1046,70 @@ instance Binary IfaceType where
               3 -> do ag <- get bh
                       ah <- get bh
                       return (IfaceFunTy ag ah)
-              4 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
-              5 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
-              6 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
-              _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
+              
+                -- Now the special cases for TyConApp
+              6 -> return (IfaceTyConApp IfaceIntTc [])
+              7 -> return (IfaceTyConApp IfaceCharTc [])
+              8 -> return (IfaceTyConApp IfaceBoolTc [])
+              9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
+              10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
+              11 -> do { t1 <- get bh; t2 <- get bh
+                       ; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
+              12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
+              13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
+              14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
+              15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
+              16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
+              17 -> return (IfaceTyConApp IfaceConstraintKindTc [])
+              18 -> return (IfaceTyConApp IfaceSuperKindTc [])
+
+              19 -> do { cc <- get bh; tys <- get bh
+                        ; return (IfaceCoConApp cc tys) }
+
+              20 -> do { tc <- get bh; tys <- get bh
+                       ; return (IfaceTyConApp (IfaceTc tc) tys) }
+              21 -> do { tc <- get bh; tys <- get bh
+                        ; return (IfaceTyConApp tc tys) }
+
+              _  -> panic ("get IfaceType " ++ show h)
 
 instance Binary IfaceTyCon where
-   put_ bh (IfaceTc ext)  = do { putByte bh 1; put_ bh ext }
-   put_ bh (IfaceAnyTc k) = do { putByte bh 2; put_ bh k }
+        -- Int,Char,Bool can't show up here because they can't not be saturated
+   put_ bh IfaceIntTc         = putByte bh 1
+   put_ bh IfaceBoolTc        = putByte bh 2
+   put_ bh IfaceCharTc        = putByte bh 3
+   put_ bh IfaceListTc        = putByte bh 4
+   put_ bh IfacePArrTc        = putByte bh 5
+   put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
+   put_ bh IfaceOpenTypeKindTc     = putByte bh 7
+   put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
+   put_ bh IfaceUbxTupleKindTc     = putByte bh 9
+   put_ bh IfaceArgTypeKindTc      = putByte bh 10
+   put_ bh IfaceConstraintKindTc   = putByte bh 11
+   put_ bh IfaceSuperKindTc        = putByte bh 12
+   put_ bh (IfaceTupTc bx ar)  = do { putByte bh 13; put_ bh bx; put_ bh ar }
+   put_ bh (IfaceTc ext)       = do { putByte bh 14; put_ bh ext }
+   put_ bh (IfaceIPTc n)       = do { putByte bh 15; put_ bh n }
 
    get bh = do
         h <- getByte bh
         case h of
-          1 -> do { ext <- get bh; return (IfaceTc ext) }
-          _ -> do { k <- get bh; return (IfaceAnyTc k) }
+          1 -> return IfaceIntTc
+          2 -> return IfaceBoolTc
+          3 -> return IfaceCharTc
+          4 -> return IfaceListTc
+          5 -> return IfacePArrTc
+          6 -> return IfaceLiftedTypeKindTc 
+          7 -> return IfaceOpenTypeKindTc 
+          8 -> return IfaceUnliftedTypeKindTc
+          9 -> return IfaceUbxTupleKindTc
+          10 -> return IfaceArgTypeKindTc
+          11 -> return IfaceConstraintKindTc
+          12 -> return IfaceSuperKindTc
+          13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
+          14 -> do { ext <- get bh; return (IfaceTc ext) }
+          15 -> do { n <- get bh; return (IfaceIPTc n) }
+          _  -> panic ("get IfaceTyCon " ++ show h)
 
 instance Binary IfaceCoCon where
    put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
@@ -1061,7 +1131,8 @@ instance Binary IfaceCoCon where
           4 -> return IfaceTransCo
           5 -> return IfaceInstCo
           6 -> do { d <- get bh; return (IfaceNthCo d) }
-          _ -> do { ip <- get bh; return (IfaceIPCoAx ip) }
+          7 -> do { ip <- get bh; return (IfaceIPCoAx ip) }
+          _ -> panic ("get IfaceCoCon " ++ show h)
 
 -------------------------------------------------------------------------
 --              IfaceExpr and friends
index 348da8c..9d4a825 100644 (file)
@@ -15,6 +15,7 @@ module BuildTyCl (
        buildSynTyCon, 
         buildAlgTyCon, 
         buildDataCon,
+        buildPromotedDataTyCon,
         TcMethInfo, buildClass,
        distinctAbstractTyConRhs, totallyAbstractTyConRhs,
        mkNewTyConRhs, mkDataTyConRhs, 
@@ -34,11 +35,13 @@ import MkId
 import Class
 import TyCon
 import Type
+import Kind             ( promoteType, isPromotableType )
 import Coercion
 
 import TcRnMonad
 import Util            ( isSingleton )
 import Outputable
+import Unique           ( getUnique )
 \end{code}
        
 
@@ -59,11 +62,10 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family
 
   | otherwise
   = return (mkSynTyCon tc_name kind tvs rhs parent)
-  where
-    kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
+  where kind = mkForAllArrowKinds tvs rhs_kind
 
 ------------------------------------------------------
-buildAlgTyCon :: Name -> [TyVar] 
+buildAlgTyCon :: Name -> [TyVar]        -- ^ Kind variables adn type variables
              -> ThetaType              -- ^ Stupid theta
              -> AlgTyConRhs
              -> RecFlag
@@ -72,22 +74,21 @@ buildAlgTyCon :: Name -> [TyVar]
              -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
              -> TcRnIf m n TyCon
 
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
+buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn
              parent mb_family
   | Just fam_inst_info <- mb_family
   = -- We need to tie a knot as the coercion of a data instance depends
      -- on the instance representation tycon and vice versa.
     ASSERT( isNoParent parent )
     fixM $ \ tycon_rec -> do 
-    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
-    ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+    { fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec
+    ; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
                         fam_parent is_rec gadt_syn) }
 
   | otherwise
-  = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+  = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
                       parent is_rec gadt_syn)
-  where
-    kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
+  where kind = mkForAllArrowKinds ktvs liftedTypeKind
 
 -- | If a family tycon with instance types is given, the current tycon is an
 -- instance of that family and we need to
@@ -224,6 +225,11 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
     arg_tyvars      = tyVarsOfTypes arg_tys
     in_arg_tys pred = not $ isEmptyVarSet $ 
                      tyVarsOfType pred `intersectVarSet` arg_tyvars
+
+buildPromotedDataTyCon :: DataCon -> TyCon
+buildPromotedDataTyCon dc = ASSERT ( isPromotableType ty )
+  mkPromotedDataTyCon dc (getName dc) (getUnique dc) (promoteType ty)
+  where ty = dataConUserType dc
 \end{code}
 
 
@@ -301,7 +307,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
                 then mkNewTyConRhs tycon_name rec_tycon dict_con
                 else return (mkDataTyConRhs [dict_con])
 
-       ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) constraintKind
+       ; let { clas_kind = mkForAllArrowKinds tvs constraintKind
 
              ; tycon = mkClassTyCon tycon_name clas_kind tvs
                                     rhs rec_clas tc_isrec
index deeac37..92fb0d9 100644 (file)
@@ -500,6 +500,7 @@ pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
                                                             (map (pprIfaceConDecl tc) cs))
 
 mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
+-- IA0_NOTE: This is wrong, but only used for pretty-printing.
 mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2]
 
 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
@@ -718,7 +719,9 @@ freeNamesIfDecl d@IfaceData{} =
 freeNamesIfDecl d@IfaceSyn{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfSynRhs (ifSynRhs d) &&&
-  freeNamesIfTcFam (ifFamInst d)
+  freeNamesIfTcFam (ifFamInst d) &&&
+  freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we
+                                -- return names in the kind signature
 freeNamesIfDecl d@IfaceClass{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfContext (ifCtxt d) &&&
@@ -769,6 +772,9 @@ freeNamesIfConDecl c =
   fnList freeNamesIfType (ifConArgTys c) &&&
   fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
 
+freeNamesIfKind :: IfaceType -> NameSet
+freeNamesIfKind = freeNamesIfType
+
 freeNamesIfType :: IfaceType -> NameSet
 freeNamesIfType (IfaceTyVar _)        = emptyNameSet
 freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
@@ -795,8 +801,8 @@ freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
                                              &&& freeNamesIfIdInfo info
 
 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
-freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
-    -- kinds can have Names inside, when the Kind is an equality predicate
+freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
+    -- kinds can have Names inside, because of promotion
 
 freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
 freeNamesIfIdBndr = freeNamesIfTvBndr
index 471acd0..5441287 100644 (file)
@@ -21,7 +21,7 @@ module IfaceType (
        ifaceTyConName,
 
        -- Conversion from Type -> IfaceType
-        toIfaceType, toIfaceContext,
+        toIfaceType, toIfaceKind, toIfaceContext,
        toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, 
        toIfaceTyCon, toIfaceTyCon_name,
 
@@ -87,12 +87,20 @@ data IfaceType         -- A kind of universal type, used for types, kinds, and coerci
 type IfacePredType = IfaceType
 type IfaceContext = [IfacePredType]
 
-data IfaceTyCon         -- Encodes type consructors, kind constructors
-                        -- coercion constructors, the lot
-  = IfaceTc IfExtName   -- The common case
-  | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
-                        -- other than 'Any :: *' itself
-                         -- XXX: remove this case after Any becomes kind-polymorphic
+data IfaceTyCon        -- Encodes type constructors, kind constructors
+                       -- coercion constructors, the lot
+  = IfaceTc IfExtName  -- The common case
+  | IfaceIntTc | IfaceBoolTc | IfaceCharTc
+  | IfaceListTc | IfacePArrTc
+  | IfaceTupTc TupleSort Arity 
+  | IfaceIPTc IfIPName       -- Used for implicit parameter TyCons
+
+  -- Kind constructors
+  | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
+  | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc
+
+  -- SuperKind constructor
+  | IfaceSuperKindTc  -- IA0_NOTE: You might want to check if I didn't forget something.
 
   -- Coercion constructors
 data IfaceCoCon
@@ -103,13 +111,29 @@ data IfaceCoCon
   | IfaceNthCo Int
 
 ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName IfaceIntTc              = intTyConName
+ifaceTyConName IfaceBoolTc            = boolTyConName
+ifaceTyConName IfaceCharTc            = charTyConName
+ifaceTyConName IfaceListTc            = listTyConName
+ifaceTyConName IfacePArrTc            = parrTyConName
+ifaceTyConName (IfaceTupTc bx ar)      = getName (tupleTyCon bx ar)
+ifaceTyConName IfaceLiftedTypeKindTc   = liftedTypeKindTyConName
+ifaceTyConName IfaceOpenTypeKindTc     = openTypeKindTyConName
+ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
+ifaceTyConName IfaceUbxTupleKindTc     = ubxTupleKindTyConName
+ifaceTyConName IfaceArgTypeKindTc      = argTypeKindTyConName
+ifaceTyConName IfaceConstraintKindTc   = constraintKindTyConName
+ifaceTyConName IfaceSuperKindTc        = tySuperKindTyConName
 ifaceTyConName (IfaceTc ext)           = ext
-ifaceTyConName (IfaceAnyTc k)          = pprPanic "ifaceTyConName:AnyTc" (ppr k)
+ifaceTyConName (IfaceIPTc n)           = pprPanic "ifaceTyConName:IPTc" (ppr n)
                                         -- Note [The Name of an IfaceAnyTc]
 \end{code}
 
 Note [The Name of an IfaceAnyTc]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+IA0_NOTE: This is an old comment. It needs to be updated with IPTc which
+I don't know about.
+
 It isn't easy to get the Name of an IfaceAnyTc in a pure way.  What you
 really need to do is to transform it to a TyCon, and get the Name of that.
 But doing so needs the monad because there's an IfaceKind inside, and we
@@ -190,8 +214,7 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
 pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
 
 pprIfaceTvBndr :: IfaceTvBndr -> SDoc
-pprIfaceTvBndr (tv, IfaceTyConApp (IfaceTc n) [])
-  | n == liftedTypeKindTyConName
+pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc [])
   = ppr tv
 pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
 pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
@@ -255,18 +278,21 @@ pprIfaceForAllPart tvs ctxt doc
 
 -------------------
 ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc
-ppr_tc_app _         tc         []   = ppr_tc tc
-ppr_tc_app _         (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty)
-ppr_tc_app _         (IfaceTc n) [ty] | n == parrTyConName = pabrackets (pprIfaceType ty)
-ppr_tc_app _         (IfaceTc n) tys
-  | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
-  , Just sort <- tyConTuple_maybe tc
-  , tyConArity tc == length tys 
-  = tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
-  | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
-  , Just ip <- tyConIP_maybe tc
-  , [ty] <- tys
-  = parens (ppr ip <> dcolon <> pprIfaceType ty)
+ppr_tc_app _         tc          []   = ppr_tc tc
+
+ppr_tc_app _         IfaceListTc [ty] = brackets (pprIfaceType ty)
+ppr_tc_app _         IfaceListTc _    = panic "ppr_tc_app IfaceListTc"
+
+ppr_tc_app _         IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
+ppr_tc_app _         IfacePArrTc _    = panic "ppr_tc_app IfacePArrTc"
+
+ppr_tc_app _         (IfaceTupTc sort _) tys =
+  tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
+
+ppr_tc_app _         (IfaceIPTc n) [ty] =
+  parens (ppr n <> dcolon <> pprIfaceType ty)
+ppr_tc_app _         (IfaceIPTc _) _ = panic "ppr_tc_app IfaceIPTc"
+
 ppr_tc_app ctxt_prec tc tys
   = maybeParen ctxt_prec tYCON_PREC 
                (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
@@ -278,11 +304,8 @@ ppr_tc tc             = ppr tc
 
 -------------------
 instance Outputable IfaceTyCon where
-  ppr (IfaceAnyTc k) = ptext (sLit "Any") <> pprParendIfaceType k
-                            -- We can't easily get the Name of an IfaceAnyTc
-                            -- (see Note [The Name of an IfaceAnyTc])
-                            -- so we fake it.  It's only for debug printing!
-  ppr (IfaceTc ext)  = ppr ext
+  ppr (IfaceIPTc n)  = ppr (IPName n)
+  ppr other_tc       = ppr (ifaceTyConName other_tc)
 
 instance Outputable IfaceCoCon where
   ppr (IfaceCoAx n)    = ppr n
@@ -350,8 +373,9 @@ toIfaceCoVar = occNameFS . getOccName
 ----------------
 toIfaceTyCon :: TyCon -> IfaceTyCon
 toIfaceTyCon tc 
-  | isAnyTyCon tc              = IfaceAnyTc (toIfaceKind (tyConKind tc))
-  | otherwise                 = IfaceTc (tyConName tc)
+  | isTupleTyCon tc            = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
+  | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
+  | otherwise                 = toIfaceTyCon_name (tyConName tc)
 
 toIfaceTyCon_name :: Name -> IfaceTyCon
 toIfaceTyCon_name nm
@@ -362,7 +386,20 @@ toIfaceTyCon_name nm
 
 toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
 toIfaceWiredInTyCon tc nm
-  | isAnyTyCon tc                   = IfaceAnyTc (toIfaceKind (tyConKind tc))
+  | isTupleTyCon tc                 = IfaceTupTc  (tupleTyConSort tc) (tyConArity tc)
+  | Just n <- tyConIP_maybe tc      = IfaceIPTc (ipFastString n)
+  | nm == intTyConName              = IfaceIntTc
+  | nm == boolTyConName             = IfaceBoolTc 
+  | nm == charTyConName             = IfaceCharTc 
+  | nm == listTyConName             = IfaceListTc 
+  | nm == parrTyConName             = IfacePArrTc 
+  | nm == liftedTypeKindTyConName   = IfaceLiftedTypeKindTc
+  | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc
+  | nm == openTypeKindTyConName     = IfaceOpenTypeKindTc
+  | nm == argTypeKindTyConName      = IfaceArgTypeKindTc
+  | nm == constraintKindTyConName   = IfaceConstraintKindTc
+  | nm == ubxTupleKindTyConName     = IfaceUbxTupleKindTc
+  | nm == tySuperKindTyConName      = IfaceSuperKindTc
   | otherwise                      = IfaceTc nm
 
 ----------------
index f047f58..86c46ba 100644 (file)
@@ -1490,7 +1490,7 @@ classToIfaceDecl clas
       = IfaceAT (tyThingToIfaceDecl (ATyCon tc))
                 (map to_if_at_def defs)
       where
-        to_if_at_def (ATD tvs pat_tys ty)
+        to_if_at_def (ATD tvs pat_tys ty _loc)
           = IfaceATD (toIfaceTvBndrs tvs) (map toIfaceType pat_tys) (toIfaceType ty)
 
     toIfaceClassOp (sel_id, def_meth)
index a11051b..125b885 100644 (file)
@@ -41,7 +41,7 @@ import TyCon
 import DataCon
 import PrelNames
 import TysWiredIn
-import TysPrim          ( anyTyConOfKind )
+import TysPrim          ( tySuperKindTyCon )
 import BasicTypes       ( Arity, strongLoopBreaker )
 import Literal
 import qualified Var
@@ -502,7 +502,9 @@ tc_iface_decl _parent ignore_prags
        return tc
 
    tc_iface_at_def (IfaceATD tvs pat_tys ty) =
-       bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (ATD tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty)
+       bindIfaceTyVars_AT tvs $
+         \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
+                           (mapM tcIfaceType pat_tys) (tcIfaceType ty)
 
    mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
 
@@ -1235,9 +1237,15 @@ tcIfaceGlobal name
 -- emasculated form (e.g. lacking data constructors).
 
 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon (IfaceAnyTc kind)  = do { tc_kind <- tcIfaceType kind
-                                     ; tcWiredInTyCon (anyTyConOfKind tc_kind) }
-tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name 
+tcIfaceTyCon IfaceIntTc         = tcWiredInTyCon intTyCon
+tcIfaceTyCon IfaceBoolTc        = tcWiredInTyCon boolTyCon
+tcIfaceTyCon IfaceCharTc        = tcWiredInTyCon charTyCon
+tcIfaceTyCon IfaceListTc        = tcWiredInTyCon listTyCon
+tcIfaceTyCon IfacePArrTc        = tcWiredInTyCon parrTyCon
+tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceIPTc n)      = do { n' <- newIPName n
+                                     ; tcWiredInTyCon (ipTyCon n') }
+tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name
                                      ; return (check_tc (tyThingTyCon thing)) }
   where
     check_tc tc
@@ -1245,6 +1253,14 @@ tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name
                    IfaceTc _ -> tc
                    _         -> pprTrace "check_tc" (ppr tc) tc
      | otherwise = tc
+-- we should be okay just returning Kind constructors without extra loading
+tcIfaceTyCon IfaceLiftedTypeKindTc   = return liftedTypeKindTyCon
+tcIfaceTyCon IfaceOpenTypeKindTc     = return openTypeKindTyCon
+tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
+tcIfaceTyCon IfaceArgTypeKindTc      = return argTypeKindTyCon
+tcIfaceTyCon IfaceUbxTupleKindTc     = return ubxTupleKindTyCon
+tcIfaceTyCon IfaceConstraintKindTc   = return constraintKindTyCon
+tcIfaceTyCon IfaceSuperKindTc        = return tySuperKindTyCon
 
 -- Even though we are in an interface file, we want to make
 -- sure the instances and RULES of this tycon are loaded 
@@ -1310,12 +1326,22 @@ bindIfaceTyVar (occ,kind) thing_inside
 
 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 bindIfaceTyVars bndrs thing_inside
-  = do  { names <- newIfaceNames (map mkTyVarOccFS occs)
-        ; tyvars <- zipWithM mk_iface_tyvar names kinds
-        ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
+  = do { names <- newIfaceNames (map mkTyVarOccFS occs)
+        ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds
+              (kis_name, tys_name) = splitAt (length kis_kind) names
+          -- We need to bring the kind variables in scope since type
+          -- variables may mention them.
+        ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind
+        ; extendIfaceTyVarEnv kvs $ do
+        { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind
+        ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } }
   where
     (occs,kinds) = unzip bndrs
 
+isSuperIfaceKind :: IfaceKind -> Bool
+isSuperIfaceKind (IfaceTyConApp IfaceSuperKindTc []) = True
+isSuperIfaceKind _ = False
+
 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind
    = do { kind <- tcIfaceType ifKind
@@ -1328,12 +1354,14 @@ bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 -- Here 'a' is in scope when we look at the 'data T'
 bindIfaceTyVars_AT [] thing_inside
   = thing_inside []
-bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside 
-  = bindIfaceTyVars_AT bs $ \ bs' ->
-    do { mb_tv <- lookupIfaceTyVar tv_occ
-       ; case mb_tv of
-           Just b' -> thing_inside (b':bs')
-           Nothing -> bindIfaceTyVar b $ \ b' -> 
-                      thing_inside (b':bs') }
-\end{code} 
+bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
+  = do { mb_tv <- lookupIfaceTyVar tv_occ
+       ; let bind_b :: (TyVar -> IfL a) -> IfL a
+             bind_b = case mb_tv of
+                        Just b' -> \k -> k b'
+                        Nothing -> bindIfaceTyVar b
+       ; bind_b $ \b' ->
+         bindIfaceTyVars_AT bs $ \bs' ->
+         thing_inside (b':bs') }
+\end{code}
 
index 19bce9f..2c0cccb 100644 (file)
@@ -393,7 +393,8 @@ data ExtensionFlag
    | Opt_DoAndIfThenElse
    | Opt_RebindableSyntax
    | Opt_ConstraintKinds
-
+   | Opt_PolyKinds                -- Kind polymorphism
+   
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
    | Opt_DeriveFunctor
@@ -1904,7 +1905,8 @@ xFlags = [
   ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, nop ),
   ( "RebindableSyntax",                 Opt_RebindableSyntax, nop ),
   ( "ConstraintKinds",                  Opt_ConstraintKinds, nop ),
-  ( "MonoPatBinds",                     Opt_MonoPatBinds,
+  ( "PolyKinds",                        Opt_PolyKinds, nop ),
+  ( "MonoPatBinds",                     Opt_MonoPatBinds, 
     \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, nop ),
@@ -1988,7 +1990,9 @@ impliedFlags
     , (Opt_TypeFamilies,     turnOn, Opt_MonoLocalBinds)
 
     , (Opt_TypeFamilies,     turnOn, Opt_KindSignatures)  -- Type families use kind signatures
-                                                     -- all over the place
+                                                          -- all over the place
+
+    , (Opt_PolyKinds,        turnOn, Opt_KindSignatures)
 
     , (Opt_ImpredicativeTypes,  turnOn, Opt_RankNTypes)
 
index 039e8f1..d60e6d7 100644 (file)
@@ -264,7 +264,7 @@ import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
 import HsSyn hiding ((<.>))
 import Type     hiding( typeKind )
-import Coercion                ( synTyConResKind )
+import Kind            ( synTyConResKind )
 import TcType          hiding( typeKind )
 import Id
 import TysPrim         ( alphaTyVars )
@@ -881,7 +881,7 @@ compileCore simplify fn = do
         gutsToCoreModule (Right mg) = CoreModule {
           cm_module  = mg_module mg,
           cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
-                                           (mg_tcs mg) (mg_clss mg)
+                                           (mg_tcs mg)
                                            (mg_fam_insts mg),
           cm_binds   = mg_binds mg
          }
index 753f044..ca524aa 100644 (file)
@@ -83,7 +83,6 @@ import DsMeta           ( templateHaskellNames )
 import VarSet
 import VarEnv           ( emptyTidyEnv )
 import Panic
-import Class
 import Data.List
 #endif
 
@@ -1384,8 +1383,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
     hsc_env <- getHscEnv
     liftIO $ linkDecls hsc_env src_span cbc
 
-    let tcs  = filter (not . isImplicitTyCon) $ mg_tcs simpl_mg
-        clss = mg_clss simpl_mg
+    let tcs         = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg)
 
         ext_vars = filter (isExternalName . idName) $
                       bindersOfBinds core_binds
@@ -1400,7 +1398,6 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
 
         tythings =  map AnId user_vars
                  ++ map ATyCon tcs
-                 ++ map (ATyCon . classTyCon) clss
 
     let ictxt1 = extendInteractiveContext icontext tythings
         ictxt  = ictxt1 { ic_sys_vars  = sys_vars ++ ic_sys_vars ictxt1,
@@ -1506,7 +1503,6 @@ mkModGuts mod binds =
         mg_rdr_env      = emptyGlobalRdrEnv,
         mg_fix_env      = emptyFixityEnv,
         mg_tcs          = [],
-        mg_clss         = [],
         mg_insts        = [],
         mg_fam_insts    = [],
         mg_rules        = [],
index c2cf279..3391f6a 100644 (file)
@@ -813,7 +813,7 @@ data ModGuts
         mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module
                                          -- ToDo: I'm unconvinced this is actually used anywhere
         mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
-        mg_clss      :: ![Class],        -- ^ Classes declared in this module
+                                         -- (includes TyCons for classes)
         mg_insts     :: ![Instance],     -- ^ Class instances declared in this module
         mg_fam_insts :: ![FamInst],      -- ^ Family instances declared in this module
         mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains 
@@ -1317,14 +1317,14 @@ mkTypeEnvWithImplicits things =
     `plusNameEnv`
   mkTypeEnv (concatMap implicitTyThings things)
 
-typeEnvFromEntities :: [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv
-typeEnvFromEntities ids tcs clss faminsts =
+typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+typeEnvFromEntities ids tcs faminsts =
   mkTypeEnv (   map AnId ids
              ++ map ATyCon all_tcs
              ++ concatMap implicitTyConThings all_tcs
             )
  where
-  all_tcs = tcs ++ map classTyCon clss ++ map famInstTyCon faminsts
+  all_tcs = tcs ++ map famInstTyCon faminsts
 
 lookupTypeEnv = lookupNameEnv
 
index b2a6b5b..ef17f31 100644 (file)
@@ -129,7 +129,6 @@ mkBootModDetailsTc hsc_env
         TcGblEnv{ tcg_exports   = exports,
                   tcg_type_env  = type_env, -- just for the Ids
                   tcg_tcs       = tcs,
-                  tcg_clss      = clss,
                   tcg_insts     = insts,
                   tcg_fam_insts = fam_insts
                 }
@@ -139,7 +138,7 @@ mkBootModDetailsTc hsc_env
        ; let { insts'     = tidyInstances globaliseAndTidyId insts
              ; dfun_ids   = map instanceDFunId insts'
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
-                                (typeEnvIds type_env) tcs clss fam_insts
+                                (typeEnvIds type_env) tcs fam_insts
              ; type_env'  = extendTypeEnvWithIds type_env1 dfun_ids
              }
        ; return (ModDetails { md_types     = type_env'
@@ -153,10 +152,10 @@ mkBootModDetailsTc hsc_env
        }
   where
 
-mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv
-mkBootTypeEnv exports ids tcs clss fam_insts
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+mkBootTypeEnv exports ids tcs fam_insts
   = tidyTypeEnv True False exports $
-       typeEnvFromEntities final_ids tcs clss fam_insts
+       typeEnvFromEntities final_ids tcs fam_insts
   where
         -- Find the LocalIds in the type env that are exported
        -- Make them into GlobalIds, and tidy their types
@@ -294,7 +293,6 @@ tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
 tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_exports   = exports
                               , mg_tcs       = tcs
-                              , mg_clss      = clss
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
                               , mg_binds     = binds
@@ -314,7 +312,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               }
         ; showPass dflags CoreTidy
 
-        ; let { type_env = typeEnvFromEntities [] tcs clss fam_insts
+        ; let { type_env = typeEnvFromEntities [] tcs fam_insts
 
               ; implicit_binds
                   = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
index c036d74..b32dd8a 100644 (file)
@@ -524,6 +524,7 @@ data Token
   | ITcomma
   | ITunderscore
   | ITbackquote
+  | ITsimpleQuote               --  '
 
   | ITvarid   FastString        -- identifiers
   | ITconid   FastString
@@ -558,7 +559,6 @@ data Token
   | ITcloseQuote                --  |]
   | ITidEscape   FastString     --  $x
   | ITparenEscape               --  $(
-  | ITvarQuote                  --  '
   | ITtyQuote                   --  ''
   | ITquasiQuote (FastString,FastString,RealSrcSpan) --  [:...|...|]
 
@@ -1229,7 +1229,7 @@ lex_stringgap s = do
 lex_char_tok :: Action
 -- Here we are basically parsing character literals, such as 'x' or '\n'
 -- but, when Template Haskell is on, we additionally spot
--- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
+-- 'x and ''T, returning ITsimpleQuote and ITtyQuote respectively,
 -- but WITHOUT CONSUMING the x or T part  (the parser does that).
 -- So we have to do two characters of lookahead: when we see 'x we need to
 -- see if there's a trailing quote
@@ -1240,11 +1240,8 @@ lex_char_tok span _buf _len = do        -- We've seen '
         Nothing -> lit_error  i1
 
         Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''
-                  th_exts <- extension thEnabled
-                  if th_exts then do
-                        setInput i2
-                        return (L (mkRealSrcSpan loc end2)  ITtyQuote)
-                   else lit_error i1
+                   setInput i2
+                   return (L (mkRealSrcSpan loc end2)  ITtyQuote)
 
         Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash
                   setInput i2
@@ -1267,10 +1264,8 @@ lex_char_tok span _buf _len = do        -- We've seen '
                 _other -> do            -- We've seen 'x not followed by quote
                                         -- (including the possibility of EOF)
                                         -- If TH is on, just parse the quote only
-                        th_exts <- extension thEnabled
                         let (AI end _) = i1
-                        if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
-                                   else lit_error i2
+                        return (L (mkRealSrcSpan loc end) ITsimpleQuote)
 
 finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
 finish_char_tok loc ch  -- We've already seen the closing quote
old mode 100644 (file)
new mode 100755 (executable)
index b1c0bbb..b390009
@@ -32,7 +32,7 @@ import RdrHsSyn
 import HscTypes         ( IsBootInterface, WarningTxt(..) )
 import Lexer
 import RdrName
-import TysPrim          ( eqPrimTyCon )
+import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
 import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
                           unboxedSingletonTyCon, unboxedSingletonDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
@@ -45,8 +45,7 @@ import DataCon          ( DataCon, dataConName )
 import SrcLoc
 import Module
 import StaticFlags      ( opt_SccProfilingOn, opt_Hpc )
-import Type             ( Kind, liftedTypeKind, unliftedTypeKind )
-import Coercion         ( mkArrowKind )
+import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
 import Class            ( FunDep )
 import BasicTypes
 import DynFlags
@@ -310,6 +309,7 @@ incorrect.
  ';'            { L _ ITsemi }
  ','            { L _ ITcomma }
  '`'            { L _ ITbackquote }
+ SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x
 
  VARID          { L _ (ITvarid    _) }          -- identifiers
  CONID          { L _ (ITconid    _) }
@@ -349,7 +349,6 @@ incorrect.
 '|]'            { L _ ITcloseQuote    }
 TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
 '$('            { L _ ITparenEscape   }     -- $( exp )
-TH_VAR_QUOTE    { L _ ITvarQuote      }     -- 'x
 TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
 TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
 
@@ -718,9 +717,9 @@ data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
         | 'newtype'     { L1 NewType }
 
-opt_kind_sig :: { Located (Maybe Kind) }
+opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
         :                               { noLoc Nothing }
-        | '::' kind                     { LL (Just (unLoc $2)) }
+        | '::' kind                     { LL (Just $2) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -968,8 +967,8 @@ sigtypes1 :: { [LHsType RdrName] }      -- Always HsForAllTys
 -- Types
 
 infixtype :: { LHsType RdrName }
-        : btype qtyconop type         { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  type    { LL $ HsOpTy $1 $2 $3 }
+        : btype qtyconop type         { LL $ mkHsOpTy $1 $2 $3 }
+        | btype tyvarop  type    { LL $ mkHsOpTy $1 $2 $3 }
 
 strict_mark :: { Located HsBang }
         : '!'                           { L1 HsStrict }
@@ -1020,18 +1019,21 @@ context :: { LHsContext RdrName }
 
 type :: { LHsType RdrName }
         : btype                         { $1 }
-        | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  type           { LL $ HsOpTy $1 $2 $3 }
+        | btype qtyconop type           { LL $ mkHsOpTy $1 $2 $3 }
+        | btype tyvarop  type           { LL $ mkHsOpTy $1 $2 $3 }
         | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
         | btype '~'      btype          { LL $ HsEqTy $1 $3 }
+                                        -- see Note [Promotion]
+        | btype SIMPLEQUOTE qconop type     { LL $ mkHsOpTy $1 $3 $4 }
+        | btype SIMPLEQUOTE varop  type     { LL $ mkHsOpTy $1 $3 $4 }
 
 typedoc :: { LHsType RdrName }
         : btype                          { $1 }
         | btype docprev                  { LL $ HsDocTy $1 $2 }
-        | btype qtyconop type            { LL $ HsOpTy $1 $2 $3 }
-        | btype qtyconop type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
-        | btype tyvarop  type            { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
+        | btype qtyconop type            { LL $ mkHsOpTy $1 $2 $3 }
+        | btype qtyconop type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
+        | btype tyvarop  type            { LL $ mkHsOpTy $1 $2 $3 }
+        | btype tyvarop  type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
         | btype '->'     ctypedoc        { LL $ HsFunTy $1 $3 }
         | btype docprev '->' ctypedoc    { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
         | btype '~'      btype           { LL $ HsEqTy $1 $3 }
@@ -1050,11 +1052,17 @@ atype :: { LHsType RdrName }
         | '[' ctype ']'                 { LL $ HsListTy  $2 }
         | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
         | '(' ctype ')'                 { LL $ HsParTy   $2 }
-        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
+        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 $4 }
         | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }
         | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
-        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $ 
+        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $
                                           mkUnqual varName (getTH_ID_SPLICE $1) }
+                                                      -- see Note [Promotion] for the followings
+        | SIMPLEQUOTE qconid                          { LL $ HsTyVar $ unLoc $2 }
+        | SIMPLEQUOTE  '(' ')'                        { LL $ HsTyVar $ getRdrName unitDataCon }
+        | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
+        | SIMPLEQUOTE  '[' comma_types0 ']'           { LL $ HsExplicitListTy placeHolderKind $3 }
+        | '[' ctype ',' comma_types1 ']'              { LL $ HsExplicitListTy placeHolderKind ($2 : $4) }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
@@ -1081,8 +1089,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) 
-                                                          (unLoc $4)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
@@ -1103,15 +1110,55 @@ varids0 :: { Located [RdrName] }
 -----------------------------------------------------------------------------
 -- Kinds
 
-kind    :: { Located Kind }
-        : akind                 { $1 }
-        | akind '->' kind       { LL (mkArrowKind (unLoc $1) (unLoc $3)) }
+kind :: { LHsKind RdrName }
+        : bkind                  { $1 }
+        | bkind '->' kind        { LL $ HsFunTy $1 $3 }
+
+bkind :: { LHsKind RdrName }
+        : akind                  { $1 }
+        | bkind akind            { LL $ HsAppTy $1 $2 }
+
+akind :: { LHsKind RdrName }
+        : '*'                    { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
+        | '(' kind ')'           { LL $ HsParTy $2 }
+        | pkind                  { $1 }
+
+pkind :: { LHsKind RdrName }  -- promoted type, see Note [Promotion]
+        : qtycon                          { L1 $ HsTyVar $ unLoc $1 }
+        | '(' ')'                         { LL $ HsTyVar $ getRdrName unitTyCon }
+        | '(' kind ',' comma_kinds1 ')'   { LL $ HsTupleTy (HsBoxyTuple placeHolderKind) ($2 : $4) }
+        | '[' kind ']'                    { LL $ HsListTy $2 }
+
+comma_kinds1 :: { [LHsKind RdrName] }
+        : kind                          { [$1] }
+        | kind  ',' comma_kinds1        { $1 : $3 }
+
+{- Note [Promotion]
+   ~~~~~~~~~~~~~~~~
+
+- Syntax of promoted qualified names
+We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified
+names. Moreover ticks are only allowed in types, not in kinds, for a
+few reasons:
+  1. we don't need quotes since we cannot define names in kinds
+  2. if one day we merge types and kinds, tick would mean look in DataName
+  3. we don't have a kind namespace anyway
+
+- Syntax of explicit kind polymorphism  (IA0_TODO: not yet implemented)
+Kind abstraction is implicit. We write
+> data SList (s :: k -> *) (as :: [k]) where ...
+because it looks like what we do in terms
+> id (x :: a) = x
+
+- Name resolution
+When the user write Zero instead of 'Zero in types, we parse it a
+HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We
+deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not
+bounded in the type level, then we look for it in the term level (we
+change its namespace to DataName, see Note [Demotion] in OccName). And
+both become a HsTyVar ("Zero", DataName) after the renamer.
 
-akind   :: { Located Kind }
-        : '*'                   { L1 liftedTypeKind }
-        | '!'                   { L1 unliftedTypeKind }
-        | CONID                 {% checkKindName (L1 (getCONID $1)) }
-        | '(' kind ')'          { LL (unLoc $2) }
+-}
 
 
 -----------------------------------------------------------------------------
@@ -1411,10 +1458,10 @@ aexp2   :: { LHsExpr RdrName }
         | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               
 
 
-        | TH_VAR_QUOTE qvar     { LL $ HsBracket (VarBr (unLoc $2)) }
-        | TH_VAR_QUOTE qcon     { LL $ HsBracket (VarBr (unLoc $2)) }
-        | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr (unLoc $2)) }
-        | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr (unLoc $2)) }
+        | SIMPLEQUOTE  qvar     { LL $ HsBracket (VarBr True  (unLoc $2)) }
+        | SIMPLEQUOTE  qcon     { LL $ HsBracket (VarBr True  (unLoc $2)) }
+        | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr False (unLoc $2)) }
+        | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr False (unLoc $2)) }
         | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
         | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
         | '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
index 99efa7a..3a786ea 100644 (file)
@@ -20,7 +20,7 @@ import Type ( Kind,
               liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
               argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp
             )
-import Coercion( mkArrowKind )
+import Kind( mkArrowKind )
 import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe )
 import Module
 import ParserCoreUtils
@@ -346,7 +346,7 @@ eqTc (IfaceTc name) tycon = name == tyConName tycon
 -- Tiresomely, we have to generate both HsTypes (in type/class decls) 
 -- and IfaceTypes (in Core expressions).  So we parse them as IfaceTypes,
 -- and convert to HsTypes here.  But the IfaceTypes we can see here
--- are very limited (see the productions for 'ty', so the translation
+-- are very limited (see the productions for 'ty'), so the translation
 -- isn't hard
 toHsType :: IfaceType -> LHsType RdrName
 toHsType (IfaceTyVar v)                         = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v))
@@ -355,12 +355,12 @@ toHsType (IfaceFunTy t1 t2)                = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 
--- We also need to convert IfaceKinds to Kinds (now that they are different).
 -- Only a limited form of kind will be encountered... hopefully
-toKind :: IfaceKind -> Kind
-toKind (IfaceFunTy ifK1 ifK2)  = mkArrowKind (toKind ifK1) (toKind ifK2)
-toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
-toKind other                   = pprPanic "toKind" (ppr other)
+toHsKind :: IfaceKind -> LHsKind RdrName
+-- IA0_NOTE: Shouldn't we add kind variables?
+toHsKind (IfaceFunTy ifK1 ifK2)  = noLoc $ HsFunTy (toHsKind ifK1) (toHsKind ifK2)
+toHsKind (IfaceTyConApp ifKc []) = noLoc $ HsTyVar (nameRdrName (tyConName (toKindTc ifKc)))
+toHsKind other                   = pprPanic "toHsKind" (ppr other)
 
 toKindTc :: IfaceTyCon -> TyCon
 toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc
@@ -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)) (toKind k)
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
index 20055e3..8ab71f3 100644 (file)
@@ -42,7 +42,6 @@ module RdrHsSyn (
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkDoAndIfThenElse,
-        checkKindName,
         checkRecordSyntax,
         parseError,
         parseErrorSDoc,
@@ -50,16 +49,13 @@ module RdrHsSyn (
 
 import HsSyn            -- Lots of it
 import Class            ( FunDep )
-import TypeRep          ( Kind )
-import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
+import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
-import OccName          ( occNameFS )
-import Name             ( Name, nameOccName )
+import Name             ( Name )
 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
                           InlinePragma(..), InlineSpec(..) )
 import Lexer
 import TysWiredIn       ( unitTyCon )
-import TysPrim          ( constraintKindTyConName, constraintKind )
 import ForeignCall
 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
                           occNameString )
@@ -110,6 +106,8 @@ extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
 extract_ltys tys acc = foldr extract_lty acc tys
 
+-- IA0_NOTE: Should this function also return kind variables?
+-- (explicit kind poly)
 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
 extract_lty (L loc ty) acc
   = case ty of
@@ -123,7 +121,7 @@ extract_lty (L loc ty) acc
       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
       HsIParamTy _ ty           -> extract_lty ty acc
       HsEqTy ty1 ty2            -> extract_lty ty1 (extract_lty ty2 acc)
-      HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
+      HsOpTy ty1 (_, (L loc tv)) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty                -> extract_lty ty acc
       HsCoreTy {}               -> acc  -- The type is closed
       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
@@ -135,6 +133,9 @@ extract_lty (L loc ty) acc
                                 where
                                    locals = hsLTyVarNames tvs
       HsDocTy ty _              -> extract_lty ty acc
+      HsExplicitListTy _ tys    -> extract_ltys tys acc
+      HsExplicitTupleTy _ tys   -> extract_ltys tys acc
+      HsWrapTy _ _              -> panic "extract_lty"
 
 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
@@ -191,7 +192,7 @@ mkTyData :: SrcSpan
          -> NewOrData
          -> Bool                -- True <=> data family instance
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe Kind
+         -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
@@ -219,7 +220,7 @@ mkTySynonym loc is_family lhs rhs
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
            -> LHsType RdrName   -- LHS
-           -> Maybe Kind        -- Optional kind signature
+           -> Maybe (LHsKind RdrName) -- Optional kind signature
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
@@ -493,7 +494,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv k placeHolderKind))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
     chk t@(L l _)
@@ -532,10 +533,10 @@ checkTyClHdr ty
   where
     goL (L l ty) acc = go l ty acc
 
-    go l (HsTyVar tc) acc
+    go l (HsTyVar tc) acc 
         | isRdrTc tc         = return (L l tc, acc)
-
-    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
+                                     
+    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
         | isRdrTc tc         = return (ltc, t1:t2:acc)
     go _ (HsParTy ty)    acc = goL ty acc
     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
@@ -776,17 +777,6 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
           expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
                  text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
                  text "else" <+> ppr elseExpr
-
-checkKindName :: Located FastString -> P (Located Kind)
-checkKindName (L l fs) = do
-    pState <- getPState
-    let ext_enabled = xopt Opt_ConstraintKinds (dflags pState)
-        is_kosher = fs == occNameFS (nameOccName constraintKindTyConName)
-    if not ext_enabled || not is_kosher
-     then parseErrorSDoc l (text "Unexpected named kind:"
-                         $$ nest 4 (ppr fs)
-                         $$ if (not ext_enabled && is_kosher) then text "Perhaps you meant to use -XConstraintKinds?" else empty)
-     else return (L l constraintKind)
 \end{code}
 
 
index ea44353..cd6a621 100644 (file)
@@ -1241,11 +1241,13 @@ eitherTyConKey                          = mkPreludeTyConUnique 84
 
 -- Super Kinds constructors
 tySuperKindTyConKey :: Unique
-tySuperKindTyConKey                    = mkPreludeTyConUnique 85
+tySuperKindTyConKey                     = mkPreludeTyConUnique 85
 
 -- Kind constructors
-liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
-    ubxTupleKindTyConKey, argTypeKindTyConKey, constraintKindTyConKey :: Unique
+liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey,
+  unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey,
+  constraintKindTyConKey :: Unique
+anyKindTyConKey                         = mkPreludeTyConUnique 86
 liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87
 openTypeKindTyConKey                    = mkPreludeTyConUnique 88
 unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89
@@ -1591,6 +1593,24 @@ mzipIdKey       = mkPreludeMiscIdUnique 197
 
 %************************************************************************
 %*                                                                      *
+\subsection{Standard groups of types}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+kindKeys :: [Unique]
+kindKeys = [ anyKindTyConKey
+           , liftedTypeKindTyConKey
+           , openTypeKindTyConKey
+           , unliftedTypeKindTyConKey
+           , ubxTupleKindTyConKey
+           , argTypeKindTyConKey
+           , constraintKindTyConKey ]
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
 \subsection[Class-std-groups]{Standard groups of Prelude classes}
 %*                                                                      *
 %************************************************************************
index 0c2de06..e97f462 100644 (file)
@@ -21,20 +21,21 @@ module TysPrim(
         tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
        alphaTy, betaTy, gammaTy, deltaTy,
        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
-        argAlphaTyVars, argAlphaTyVar, argAlphaTy, argBetaTy, argBetaTyVar,
+        argAlphaTy, argAlphaTyVar, argAlphaTyVars, argBetaTy, argBetaTyVar,
+        kKiVar,
 
         -- Kind constructors...
-        tySuperKindTyCon, tySuperKind,
+        tySuperKindTyCon, tySuperKind, anyKindTyCon,
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
 
-        tySuperKindTyConName, liftedTypeKindTyConName,
+        tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
         openTypeKindTyConName, unliftedTypeKindTyConName,
         ubxTupleKindTyConName, argTypeKindTyConName,
         constraintKindTyConName,
 
         -- Kinds
-       liftedTypeKind, unliftedTypeKind, openTypeKind,
+       anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
 
@@ -74,21 +75,20 @@ module TysPrim(
         eqPrimTyCon,            -- ty1 ~# ty2
 
        -- * Any
-       anyTy, anyTyCon, anyTyConOfKind, anyTypeOfKind
+       anyTy, anyTyCon, anyTypeOfKind
   ) where
 
 #include "HsVersions.h"
 
-import Var             ( TyVar, mkTyVar )
+import Var             ( TyVar, KindVar, mkTyVar )
 import Name            ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName          ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+import OccName          ( mkTyVarOccFS, mkTcOccFS )
 import TyCon
 import TypeRep
 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )
 import PrelNames
 import FastString
-import Outputable
 
 import Data.Char
 \end{code}
@@ -127,6 +127,7 @@ primTyCons
     , word32PrimTyCon
     , word64PrimTyCon
     , anyTyCon
+    , anyKindTyCon
     , eqPrimTyCon
 
     , liftedTypeKindTyCon
@@ -223,6 +224,10 @@ argAlphaTyVars@(argAlphaTyVar : argBetaTyVar : _) = tyVarList argTypeKind
 argAlphaTy, argBetaTy :: Type
 argAlphaTy = mkTyVarTy argAlphaTyVar
 argBetaTy  = mkTyVarTy argBetaTyVar
+
+kKiVar :: KindVar
+kKiVar = (tyVarList tySuperKind) !! 10
+
 \end{code}
 
 
@@ -237,15 +242,20 @@ funTyConName :: Name
 funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 
 funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
-        -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-       -- But if we do that we get kind errors when saying
-       --      instance Control.Arrow (->)
-       -- becuase the expected kind is (*->*->*).  The trouble is that the
-       -- expected/actual stuff in the unifier does not go contra-variant, whereas
-       -- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
-       -- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
-        -- because they are never in scope in the source
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
+-- One step to remove subkinding.
+-- (->) :: * -> * -> *
+-- but we should have (and want) the following typing rule for fully applied arrows
+--      Gamma |- tau   :: k1    k1 in {*, #}
+--      Gamma |- sigma :: k2    k2 in {*, #, (#)}
+--      -----------------------------------------
+--      Gamma |- tau -> sigma :: *
+-- Currently we have the following rule which achieves more or less the same effect
+--      Gamma |- tau   :: ??
+--      Gamma |- sigma :: ?
+--      --------------------------
+--      Gamma |- tau -> sigma :: *
+-- In the end we don't want subkinding at all.
 \end{code}
 
 
@@ -257,18 +267,19 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif
 
 \begin{code}
 -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
-tySuperKindTyCon, liftedTypeKindTyCon,
+tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon,
       openTypeKindTyCon, unliftedTypeKindTyCon,
       ubxTupleKindTyCon, argTypeKindTyCon,
       constraintKindTyCon
    :: TyCon
-tySuperKindTyConName, liftedTypeKindTyConName,
+tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
       openTypeKindTyConName, unliftedTypeKindTyConName,
       ubxTupleKindTyConName, argTypeKindTyConName,
       constraintKindTyConName
    :: Name
 
 tySuperKindTyCon      = mkSuperKindTyCon tySuperKindTyConName
+anyKindTyCon          = mkKindTyCon anyKindTyConName          tySuperKind
 liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   tySuperKind
 openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
 unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
@@ -280,6 +291,7 @@ constraintKindTyCon   = mkKindTyCon constraintKindTyConName   tySuperKind
 -- ... and now their names
 
 tySuperKindTyConName      = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
+anyKindTyConName      = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon
 liftedTypeKindTyConName   = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
 openTypeKindTyConName     = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
 unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
@@ -302,13 +314,15 @@ kindTyConType :: TyCon -> Type
 kindTyConType kind = TyConApp kind []
 
 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind
+anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind
 
+-- See Note [Any kinds]
+anyKind          = kindTyConType anyKindTyCon
 liftedTypeKind   = kindTyConType liftedTypeKindTyCon
 unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
 openTypeKind     = kindTyConType openTypeKindTyCon
 argTypeKind      = kindTyConType argTypeKindTyCon
-ubxTupleKind    = kindTyConType ubxTupleKindTyCon
+ubxTupleKind     = kindTyConType ubxTupleKindTyCon
 constraintKind   = kindTyConType constraintKindTyCon
 
 -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
@@ -406,15 +420,13 @@ Note [The ~# TyCon)
 ~~~~~~~~~~~~~~~~~~~~
 There is a perfectly ordinary type constructor ~# that represents the type
 of coercions (which, remember, are values).  For example
-   Refl Int :: ~# Int Int
+   Refl Int :: ~# Int Int
 
-Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic:
-   Refl Maybe :: ~# Maybe Maybe
+It is a kind-polymorphic type constructor like Any:
+   Refl Maybe :: ~# (* -> *) Maybe Maybe
 
-So the true kind of ~# :: forall k. k -> k -> #.  But we don't have
-polymorphic kinds (yet). However, (~) really only appears saturated in
-which case there is no problem in finding the kind of (ty1 ~# ty2). So
-we check that in CoreLint (and, in an assertion, in Kind.typeKind).
+(~) only appears saturated. So we check that in CoreLint (and, in an
+assertion, in Kind.typeKind).
 
 Note [The State# TyCon]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -436,7 +448,10 @@ statePrimTyCon      = pcPrimTyCon statePrimTyConName 1 VoidRep
 
 eqPrimTyCon :: TyCon  -- The representation type for equality predicates
                      -- See Note [The ~# TyCon]
-eqPrimTyCon  = pcPrimTyCon eqPrimTyConName 2 VoidRep
+eqPrimTyCon  = mkPrimTyCon eqPrimTyConName kind 3 VoidRep
+  where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
+        kv = kKiVar
+        k = mkTyVarTy kv
 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not
@@ -606,7 +621,7 @@ threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
 
 Note [Any types]
 ~~~~~~~~~~~~~~~~
-The type constructor Any::* has these properties
+The type constructor Any of kind forall k. k -> k has these properties:
 
   * It is defined in module GHC.Prim, and exported so that it is 
     available to users.  For this reason it's treated like any other 
@@ -629,31 +644,18 @@ The type constructor Any::* has these properties
     For example        length Any []
     See Note [Strangely-kinded void TyCons]
 
-In addition, we have a potentially-infinite family of types, one for
-each kind /other than/ *, needed to instantiate otherwise
-un-constrained type variables of kinds other than *.  This is a bit
-like tuples; there is a potentially-infinite family.  They have slightly
-different characteristics to Any::*:
-  
-  * They are built with TyCon.AnyTyCon
-  * They have non-user-writable names like "Any(*->*)" 
-  * They are not exported by GHC.Prim
-  * They are uninhabited (of course; not kind *)
-  * They have a unique derived from their OccName (see Note [Uniques of Any])
-  * Their Names do not live in the global name cache
-
-Note [Uniques of Any]
-~~~~~~~~~~~~~~~~~~~~~
-Although Any(*->*), say, doesn't have a binding site, it still needs
-to have a Unique.  Unlike tuples (which are also an infinite family)
-there is no convenient way to index them, so we use the Unique from
-their OccName instead.  That should be unique, 
-  - both wrt each other, because their strings differ
-
-  - and wrt any other Name, because Names get uniques with 
-    various 'char' tags, but the OccName of Any will 
-    get a Unique built with mkTcOccUnique, which has a particular 'char' 
-    tag; see Unique.mkTcOccUnique!
+Note [Any kinds]
+~~~~~~~~~~~~~~~~
+
+The type constructor AnyK (of sort BOX) is used internally only to zonk kind
+variables with no constraints on them. It appears in similar circumstances to
+Any, but at the kind level. For example:
+
+  type family Length (l :: [k]) :: Nat
+  type instance Length [] = Zero
+
+Length is kind-polymorphic, and when applied to the empty (promoted) list it
+will be supplied the kind AnyL: Length AnyK [].
 
 Note [Strangely-kinded void TyCons]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -683,25 +685,9 @@ anyTy :: Type
 anyTy = mkTyConTy anyTyCon
 
 anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
+  where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
 
 anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
-
-anyTyConOfKind :: Kind -> TyCon
--- Map all superkinds of liftedTypeKind to liftedTypeKind
-anyTyConOfKind kind 
-  | isLiftedTypeKind kind = anyTyCon
-  | otherwise             = tycon
-  where
-         -- Derive the name from the kind, thus:
-         --     Any(*->*), Any(*->*->*)
-         -- These are names that can't be written by the user,
-         -- and are not allocated in the global name cache
-    str = "Any" ++ showSDoc (pprParendKind kind)
-
-    occ   = mkTcOcc str
-    uniq  = getUnique occ  -- See Note [Uniques of Any]
-    name  = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
-    tycon = mkAnyTyCon name kind 
+anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
 \end{code}
index 54acefc..c6991e1 100644 (file)
@@ -420,16 +420,25 @@ mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip
 \begin{code}
 eqTyCon :: TyCon
 eqTyCon = mkAlgTyCon eqTyConName
-            (mkArrowKinds [openTypeKind, openTypeKind] constraintKind)
-            [alphaTyVar, betaTyVar]
+            (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
+            [kv, a, b]
             []      -- No stupid theta
             (DataTyCon [eqBoxDataCon] False)
             NoParentTyCon
             NonRecursive
             False
-    
+  where
+    kv = kKiVar
+    k = mkTyVarTy kv
+    a:b:_ = tyVarList k
+
 eqBoxDataCon :: DataCon
-eqBoxDataCon = pcDataCon eqBoxDataConName [alphaTyVar, betaTyVar] [TyConApp eqPrimTyCon [mkTyVarTy alphaTyVar, mkTyVarTy betaTyVar]] eqTyCon
+eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon
+  where
+    kv = kKiVar
+    k = mkTyVarTy kv
+    a:b:_ = tyVarList k
+    args = [kv, a, b]
 \end{code}
 
 \begin{code}
index 5d53713..fa3a287 100644 (file)
@@ -1762,13 +1762,13 @@ primtype BCO#
    {Primitive bytecode type.}
 
 primop   AddrToAnyOp "addrToAny#" GenPrimOp
-   Addr# -> (# Any #)
+   Addr# -> (# a #)
    {Convert an {\tt Addr\#} to a followable Any type.}
    with
    code_size = 0
 
 primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp
-   BCO# -> (# Any #)
+   BCO# -> (# a #)
    with
    out_of_line = True
 
@@ -1849,7 +1849,7 @@ pseudoop   "lazy"
 
        Like {\tt seq}, the argument of {\tt lazy} can have an unboxed type. }
 
-primtype Any
+primtype Any a
        { The type constructor {\tt Any} is type to which you can unsafely coerce any
        lifted type, and back. 
 
@@ -1880,6 +1880,9 @@ primtype Any
        into interface files, we'll get a crash; at least until we add interface-file
        syntax to support them. }
 
+primtype AnyK
+       { JPM Todo }
+
 pseudoop   "unsafeCoerce#"
    a -> b
    { The function {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That
index faecd40..51cd09f 100644 (file)
@@ -696,7 +696,7 @@ renameSig ctxt sig@(GenericSig vs ty)
        ; return (GenericSig new_v new_ty) }
 
 renameSig _ (SpecInstSig ty)
-  = do { new_ty <- rnLHsType (text "In a SPECIALISE instance pragma") ty
+  = do { new_ty <- rnLHsType SpecInstSigCtx ty
        ; return (SpecInstSig new_ty) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
index c6ab6bb..c919e46 100644 (file)
@@ -14,7 +14,7 @@
 module RnEnv ( 
        newTopSrcBinder, 
        lookupLocatedTopBndrRn, lookupTopBndrRn,
-       lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
+       lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
 
        HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
@@ -32,14 +32,16 @@ module RnEnv (
        addLocalFixities,
        bindLocatedLocalsFV, bindLocatedLocalsRn,
        bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
-       bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
+       extendTyVarEnvFVRn,
 
        checkDupRdrNames, checkDupAndShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, 
        addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
        warnUnusedMatches,
        warnUnusedTopBinds, warnUnusedLocalBinds,
-       dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
+       dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg,
+
+        HsDocContext(..), docOfHsDocContext
     ) where
 
 #include "HsVersions.h"
@@ -444,31 +446,61 @@ lookupLocalOccRn_maybe rdr_name
        ; return (lookupLocalRdrEnv local_env rdr_name) }
 
 -- lookupOccRn looks up an occurrence of a RdrName
+lookupOccRn :: RdrName -> RnM Name
+lookupOccRn rdr_name = do
+  opt_name <- lookupOccRn_maybe rdr_name
+  maybe (unboundName WL_Any rdr_name) return opt_name
+
+-- lookupPromotedOccRn looks up an optionally promoted RdrName.
+lookupPromotedOccRn :: RdrName -> RnM Name
+-- see Note [Demotion] in OccName
+lookupPromotedOccRn rdr_name = do {
+    -- 1. lookup the name
+    opt_name <- lookupOccRn_maybe rdr_name 
+  ; case opt_name of
+      -- 1.a. we found it!
+      Just name -> return name
+      -- 1.b. we did not find it -> 2
+      Nothing -> do {
+  ; -- 2. maybe it was implicitly promoted
+    case demoteRdrName rdr_name of
+      -- 2.a it was not in a promoted namespace
+      Nothing -> err
+      -- 2.b let's try every thing again -> 3
+      Just demoted_rdr_name -> do {
+  ; poly_kinds <- xoptM Opt_PolyKinds
+    -- 3. lookup again
+  ; opt_demoted_name <- lookupOccRn_maybe demoted_rdr_name ;
+  ; case opt_demoted_name of
+      -- 3.a. it was implicitly promoted, but confirm that we can promote
+      -- JPM: We could try to suggest turning on PolyKinds here
+      Just demoted_name -> if poly_kinds then return demoted_name else err
+      -- 3.b. use rdr_name to have a correct error message
+      Nothing -> err } } }
+  where err = unboundName WL_Any rdr_name
+
+-- lookupOccRn looks up an occurrence of a RdrName
 lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
 lookupOccRn_maybe rdr_name
   = do { local_env <- getLocalRdrEnv
-       ; case lookupLocalRdrEnv local_env rdr_name of 
-          Just name -> return (Just name)
-          Nothing   -> lookupGlobalOccRn_maybe rdr_name }
-
-lookupOccRn :: RdrName -> RnM Name
-lookupOccRn rdr_name
-  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case lookupLocalRdrEnv local_env rdr_name of {
+          Just name -> return (Just name) ;
+          Nothing   -> do
+       { mb_name <- lookupGlobalOccRn_maybe rdr_name
        ; case mb_name of {
-               Just n  -> return n ;
-               Nothing -> do
-
-       { -- We allow qualified names on the command line to refer to 
-        --  *any* name exported by any module in scope, just as if there
-        -- was an "import qualified M" declaration for every module.
-        allow_qual <- doptM Opt_ImplicitImportQualified
+                Just name  -> return (Just name) ;
+                Nothing -> do
+       { -- We allow qualified names on the command line to refer to
+         --  *any* name exported by any module in scope, just as if there
+         -- was an "import qualified M" declaration for every module.
+         allow_qual <- doptM Opt_ImplicitImportQualified
        ; is_ghci <- getIsGHCi
                -- This test is not expensive,
                -- and only happens for failed lookups
        ; if isQual rdr_name && allow_qual && is_ghci
          then lookupQualifiedName rdr_name
          else do { traceRn (text "lookupOccRn" <+> ppr rdr_name)
-                 ; unboundName WL_Any rdr_name } } } }
+                 ; return Nothing } } } } } }
 
 
 lookupGlobalOccRn :: RdrName -> RnM Name
@@ -564,7 +596,7 @@ addUsedRdrNames rdrs
 
 -- A qualified name on the command line can refer to any module at all: we
 -- try to load the interface if we don't already have it.
-lookupQualifiedName :: RdrName -> RnM Name
+lookupQualifiedName :: RdrName -> RnM (Maybe Name)
 lookupQualifiedName rdr_name
   | Just (mod,occ) <- isQual_maybe rdr_name
    -- Note: we want to behave as we would for a source file import here,
@@ -575,9 +607,9 @@ lookupQualifiedName rdr_name
         | avail <- mi_exports iface,
           name  <- availNames avail,
           nameOccName name == occ ] of
-      (n:ns) -> ASSERT (null ns) return n
+      (n:ns) -> ASSERT (null ns) return (Just n)
       _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name)
-              ; unboundName WL_Any rdr_name }
+              ; return Nothing }
 
   | otherwise
   = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name)
@@ -962,28 +994,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope
     return (thing, delFVs names fvs)
 
 -------------------------------------
-bindTyVarsFV ::  [LHsTyVarBndr RdrName]
-             -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-             -> RnM (a, FreeVars)
-bindTyVarsFV tyvars thing_inside
-  = bindTyVarsRn tyvars $ \ tyvars' ->
-    do { (res, fvs) <- thing_inside tyvars'
-       ; return (res, delFVs (map hsLTyVarName tyvars') fvs) }
-
-bindTyVarsRn ::  [LHsTyVarBndr RdrName]
-             -> ([LHsTyVarBndr Name] -> RnM a)
-             -> RnM a
--- Haskell-98 binding of type variables; e.g. within a data type decl
-bindTyVarsRn tyvar_names enclosed_scope
-  = bindLocatedLocalsRn located_tyvars $ \ names ->
-    do { kind_sigs_ok <- xoptM Opt_KindSignatures
-       ; unless (null kinded_tyvars || kind_sigs_ok) 
-                       (mapM_ (addErr . kindSigErr) kinded_tyvars)
-       ; enclosed_scope (zipWith replaceLTyVarName tyvar_names names) }
-  where 
-    located_tyvars = hsLTyVarLocNames tyvar_names
-    kinded_tyvars  = [n | L _ (KindedTyVar n _) <- tyvar_names]
-
 bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
   -- Find the type variables in the pattern type 
   -- signatures that must be brought into scope
@@ -1402,6 +1412,11 @@ kindSigErr thing
   = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
        2 (ptext (sLit "Perhaps you intended to use -XKindSignatures"))
 
+polyKindsErr :: Outputable a => a -> SDoc
+polyKindsErr thing
+  = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing))
+       2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
+
 
 badQualBndrErr :: RdrName -> SDoc
 badQualBndrErr rdr_name
@@ -1412,3 +1427,56 @@ opDeclErr n
   = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n))
        2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations"))
 \end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Contexts for renaming errors}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+
+data HsDocContext
+  = TypeSigCtx SDoc
+  | PatCtx
+  | SpecInstSigCtx
+  | DefaultDeclCtx
+  | ForeignDeclCtx (Located RdrName)
+  | DerivDeclCtx
+  | RuleCtx FastString
+  | TyDataCtx (Located RdrName)
+  | TySynCtx (Located RdrName)
+  | TyFamilyCtx (Located RdrName)
+  | ConDeclCtx (Located RdrName)
+  | ClassDeclCtx (Located RdrName)
+  | ExprWithTySigCtx
+  | TypBrCtx
+  | HsTypeCtx
+  | GHCiCtx
+  | SpliceTypeCtx (LHsType RdrName)
+  | ClassInstanceCtx
+  | VectDeclCtx (Located RdrName)
+
+docOfHsDocContext :: HsDocContext -> SDoc
+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"
+docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration"
+docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name
+docOfHsDocContext DerivDeclCtx = text "In a deriving declaration"
+docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name
+docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon)
+docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name)
+docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name)
+docOfHsDocContext (ConDeclCtx name) = text "In the definition of data constructor" <+> quotes (ppr name)
+docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class"    <+> ppr name
+docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature"
+docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type")
+docOfHsDocContext HsTypeCtx = text "In a type argument"
+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 f57998e..7f86380 100644 (file)
@@ -169,8 +169,13 @@ rnExpr (NegApp e _)
 -- Don't ifdef-GHCI them because we want to fail gracefully
 -- (not with an rnExpr crash) in a stage-1 compiler.
 rnExpr e@(HsBracket br_body)
-  = checkTH e "bracket"                `thenM_`
-    rnBracket br_body          `thenM` \ (body', fvs_e) ->
+  = do
+    thEnabled <- xoptM Opt_TemplateHaskell
+    unless thEnabled $
+      failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
+                      , ptext (sLit "Perhaps you intended to use -XTemplateHaskell") ] )
+    checkTH e "bracket"
+    (body', fvs_e) <- rnBracket br_body
     return (HsBracket body', fvs_e)
 
 rnExpr (HsSpliceE splice)
@@ -265,12 +270,10 @@ rnExpr (RecordUpd expr rbinds _ _ _)
                  fvExpr `plusFV` fvRbinds) }
 
 rnExpr (ExprWithTySig expr pty)
-  = do { (pty', fvTy) <- rnHsTypeFVs doc pty
+  = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty
        ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
                             rnLExpr expr
        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
-  where 
-    doc = text "In an expression type signature"
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -280,10 +283,8 @@ rnExpr (HsIf _ p b1 b2)
        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
 rnExpr (HsType a)
-  = rnHsTypeFVs doc a  `thenM` \ (t, fvT) -> 
+  = rnHsTypeFVs HsTypeCtx a    `thenM` \ (t, fvT) -> 
     return (HsType t, fvT)
-  where 
-    doc = text "In a type argument"
 
 rnExpr (ArithSeq _ seq)
   = rnArithSeq seq      `thenM` \ (new_seq, fvs) ->
@@ -590,14 +591,14 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 
 \begin{code}
 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
-rnBracket (VarBr n) 
+rnBracket (VarBr flg n) 
   = do { name <- lookupOccRn n
        ; this_mod <- getModule
        ; unless (nameIsLocalOrFrom this_mod name) $  -- Reason: deprecation checking assumes
          do { _ <- loadInterfaceForName msg name     -- the home interface is loaded, and
             ; return () }                           -- this is the only way that is going
                                                     -- to happen
-       ; return (VarBr name, unitFV name) }
+       ; return (VarBr flg name, unitFV name) }
   where
     msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 
@@ -606,10 +607,8 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 
 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
 
-rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
+rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t
                         ; return (TypBr t', fvs) }
-                   where
-                     doc = ptext (sLit "In a Template-Haskell quoted type")
 
 rnBracket (DecBrL decls) 
   = do { (group, mb_splice) <- findSplice decls
index 2d59537..5ca81d6 100644 (file)
@@ -1,4 +1,4 @@
-\begin{code}\r
+\begin{code}
 {-# OPTIONS -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
@@ -6,19 +6,19 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
-module RnExpr where\r
-import HsSyn\r
-import Name    ( Name )\r
-import NameSet ( FreeVars )\r
-import RdrName ( RdrName )\r
-import TcRnTypes\r
-\r
-rnLExpr :: LHsExpr RdrName\r
-       -> RnM (LHsExpr Name, FreeVars)\r
-\r
-rnStmts :: --forall thing.\r
-          HsStmtContext Name -> [LStmt RdrName] \r
-        -> ([Name] -> RnM (thing, FreeVars))\r
-       -> RnM (([LStmt Name], thing), FreeVars)\r
-\end{code}\r
-\r
+module RnExpr where
+import HsSyn
+import Name    ( Name )
+import NameSet ( FreeVars )
+import RdrName ( RdrName )
+import TcRnTypes
+
+rnLExpr :: LHsExpr RdrName
+       -> RnM (LHsExpr Name, FreeVars)
+
+rnStmts :: --forall thing.
+          HsStmtContext Name -> [LStmt RdrName]
+        -> ([Name] -> RnM (thing, FreeVars))
+       -> RnM (([LStmt Name], thing), FreeVars)
+\end{code}
+
index 7b0591d..e2369bb 100644 (file)
@@ -16,6 +16,7 @@ module RnHsSyn(
         charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name,
         extractHsTyVars, extractHsTyNames, extractHsTyNames_s,
         extractFunDepNames, extractHsCtxtTyNames,
+        extractHsTyVarBndrNames, extractHsTyVarBndrNames_s,
 
         -- Free variables
         hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
@@ -30,6 +31,7 @@ import Name             ( Name, getName, isTyVarName )
 import NameSet
 import BasicTypes       ( TupleSort )
 import SrcLoc
+import Panic            ( panic )
 \end{code}
 
 %************************************************************************
@@ -56,6 +58,7 @@ extractFunDepNames :: FunDep Name -> NameSet
 extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
 
 extractHsTyNames   :: LHsType Name -> NameSet
+-- Also extract names in kinds.
 extractHsTyNames ty
   = getl ty
   where
@@ -68,22 +71,24 @@ extractHsTyNames ty
     get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
     get (HsIParamTy _ ty)      = getl ty
     get (HsEqTy ty1 ty2)       = getl ty1 `unionNameSets` getl ty2
-    get (HsOpTy ty1 op ty2)    = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
+    get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
     get (HsParTy ty)           = getl ty
     get (HsBangTy _ ty)        = getl ty
     get (HsRecTy flds)         = extractHsTyNames_s (map cd_fld_type flds)
     get (HsTyVar tv)           = unitNameSet tv
     get (HsSpliceTy _ fvs _)   = fvs
     get (HsQuasiQuoteTy {})    = emptyNameSet
-    get (HsKindSig ty _)       = getl ty
+    get (HsKindSig ty ki)      = getl ty `unionNameSets` getl ki
     get (HsForAllTy _ tvs
-                    ctxt ty)   = (extractHsCtxtTyNames ctxt
-                                         `unionNameSets` getl ty)
-                                            `minusNameSet`
-                                  mkNameSet (hsLTyVarNames tvs)
+                    ctxt ty)   = extractHsTyVarBndrNames_s tvs
+                                 (extractHsCtxtTyNames ctxt
+                                  `unionNameSets` getl ty)
     get (HsDocTy ty _)         = getl ty
     get (HsCoreTy {})          = emptyNameSet  -- This probably isn't quite right
                                                -- but I don't think it matters
+    get (HsExplicitListTy _ tys) = extractHsTyNames_s tys
+    get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys
+    get (HsWrapTy {})          = panic "extractHsTyNames"
 
 extractHsTyNames_s  :: [LHsType Name] -> NameSet
 extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
@@ -91,6 +96,18 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t
 extractHsCtxtTyNames :: LHsContext Name -> NameSet
 extractHsCtxtTyNames (L _ ctxt)
   = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt
+
+extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet
+extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet
+extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki
+
+extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet
+-- Update the name set 'body' by adding the names in the binders
+-- kinds and handling scoping.
+extractHsTyVarBndrNames_s [] body = body
+extractHsTyVarBndrNames_s (b:bs) body =
+  (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b))
+  `unionNameSets` extractHsTyVarBndrNames b
 \end{code}
 
 
@@ -125,7 +142,7 @@ hsSigFVs _                 = emptyFVs
 conDeclFVs :: LConDecl Name -> FreeVars
 conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context,
                            con_details = details, con_res = res_ty}))
-  = delFVs (map hsLTyVarName tyvars) $
+  = extractHsTyVarBndrNames_s tyvars $
     extractHsCtxtTyNames context  `plusFV`
     conDetailsFVs details         `plusFV`
     conResTyFVs res_ty
index 5c28f73..740acc4 100644 (file)
@@ -314,12 +314,11 @@ rnPatAndThen mk (SigPatIn pat ty)
   = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables)
        ; if patsigs
          then do { pat' <- rnLPatAndThen mk pat
-                 ; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty)
+                 ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty)
                 ; return (SigPatIn pat' ty') }
          else do { liftCps (addErr (patSigErr ty))
                  ; rnPatAndThen mk (unLoc pat) } }
-  where
-    tvdoc = text "In a pattern type-signature"
+
        
 rnPatAndThen mk (LitPat lit)
   | HsString s <- lit
index 8b34fb4..b6247d4 100644 (file)
@@ -50,7 +50,7 @@ import SrcLoc
 import DynFlags
 import HscTypes                ( HscEnv, hsc_dflags )
 import ListSetOps       ( findDupsEq )
-import Digraph         ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
+import Digraph         ( SCC, flattenSCCs, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
 import Maybes( orElse )
@@ -359,7 +359,7 @@ rnDefaultDecl (DefaultDecl tys)
   = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys
        ; return (DefaultDecl tys', fvs) }
   where
-    doc_str = text "In a `default' declaration"
+    doc_str = DefaultDeclCtx
 \end{code}
 
 %*********************************************************
@@ -373,7 +373,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 rnHsForeignDecl (ForeignImport name ty _ spec)
   = do { topEnv :: HscEnv <- getTopEnv
        ; name' <- lookupLocatedTopBndrRn name
-       ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
+       ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
 
         -- Mark any PackageTarget style imports as coming from the current package
        ; let packageId = thisPackage $ hsc_dflags topEnv
@@ -383,16 +383,12 @@ rnHsForeignDecl (ForeignImport name ty _ spec)
 
 rnHsForeignDecl (ForeignExport name ty _ spec)
   = do { name' <- lookupLocatedOccRn name
-       ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
+       ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
        ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
        -- NB: a foreign export is an *occurrence site* for name, so 
        --     we add it to the free-variable list.  It might, for example,
        --     be imported from another module
 
-fo_decl_msg :: Located RdrName -> SDoc
-fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
-
-
 -- | For Windows DLLs we need to know what packages imported symbols are from
 --     to generate correct calls. Imported symbols are tagged with the current
 --     package, so if they get inlined across a package boundry we'll still
@@ -546,7 +542,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
                  fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
   where
-    doc = text "In the transformation rule" <+> ftext rule_name
+    doc = RuleCtx rule_name
   
     get_var (RuleBndr v)      = v
     get_var (RuleBndrSig v _) = v
@@ -715,7 +711,13 @@ rnTyClDecls tycl_ds
 
              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
 
-       ; return (map flattenSCC sccs, all_fvs) }
+       ; return ([flattenSCCs sccs], all_fvs) }
+-- JPM: This is wrong. We are calculating the SCCs but then ignore them and
+-- merge into a single, big group. This is a quick fix to allow
+-- mutually-recursive types across modules to work, given the new way of kind
+-- checking and type checking declarations in groups (see
+-- Note [Grouping of type and class declarations] in TcTyClsDecls). This "fix"
+-- fully breaks promotion; we will fix that later.
 
 rnTyClDecl :: Maybe Name  -- Just cls => this TyClDecl is nested 
                          --             inside an *instance decl* for cls
@@ -731,12 +733,16 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- and "data family"), both top level and (for an associated type) 
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
-                            , tcdFlavour = flav, tcdKind = kind }) 
-  = bindQTvs mb_cls tyvars $ \tyvars' ->
+                            , tcdFlavour = flav, tcdKind = kind })
+  = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; kind' <- rnLHsMaybeKind fmly_doc kind
+       ; let fv_kind = maybe emptyFVs extractHsTyNames kind'
+             fvs = extractHsTyVarBndrNames_s tyvars' fv_kind
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
-                           , tcdFlavour = flav, tcdKind = kind }
-                , emptyFVs)  }
+                           , tcdFlavour = flav, tcdKind = kind' }
+                , fvs) }
+  where fmly_doc = TyFamilyCtx tycon
 
 -- "data", "newtype", "data instance, and "newtype instance" declarations
 -- both top level and (for an associated type) in an instance decl
@@ -745,17 +751,19 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
                                 tcdTyPats = typats, tcdCons = condecls, 
                                 tcdKindSig = sig, tcdDerivs = derivs}
   = do { tycon' <- lookupTcdName mb_cls tydecl
+        ; sig' <- rnLHsMaybeKind data_doc sig
        ; checkTc (h98_style || null (unLoc context)) 
                   (badGadtStupidTheta tycon)
 
        ; ((tyvars', context', typats', derivs'), stuff_fvs)
-               <- bindQTvs mb_cls tyvars $ \ tyvars' -> do
+               <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do
                                 -- Checks for distinct tyvars
                   { context' <- rnContext data_doc context
                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
                    ; (derivs', fvs2) <- rn_derivs derivs
                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
                                extractHsCtxtTyNames context'
+                               `plusFV` maybe emptyFVs extractHsTyNames sig'
                   ; return ((tyvars', context', typats', derivs'), fvs) }
 
        -- For the constructor declarations, bring into scope the tyvars 
@@ -772,7 +780,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 
        ; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
                           tcdLName = tycon', tcdTyVars = tyvars', 
-                          tcdTyPats = typats', tcdKindSig = sig,
+                          tcdTyPats = typats', tcdKindSig = sig',
                           tcdCons = condecls', tcdDerivs = derivs'}, 
                   con_fvs `plusFV` stuff_fvs)
         }
@@ -780,8 +788,8 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
     h98_style = case condecls of        -- Note [Stupid theta]
                     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
                     _                                             -> True
-                                                                                 
-    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+
+    data_doc = TyDataCtx tycon
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
     rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds
@@ -790,16 +798,16 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 -- "type" and "type instance" declarations
 rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
                                      tcdTyPats = typats, tcdSynRhs = ty})
-  = bindQTvs mb_cls tyvars $ \ tyvars' -> do
+  = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
     {           -- Checks for distinct tyvars
       name' <- lookupTcdName mb_cls tydecl
     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
-    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' 
-                       , tcdTyPats = typats', tcdSynRhs = ty'},
-             fvs1 `plusFV` fvs2) }
+    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
+                       , tcdTyPats = typats', tcdSynRhs = ty'}
+             , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
   where
-    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
+    syn_doc = TySynCtx name
 
 rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
                         tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
@@ -810,10 +818,10 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 
        -- Tyvars scope over superclass context and method signatures
        ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-           <- bindTyVarsFV tyvars $ \ tyvars' -> do
+           <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do
                 -- Checks for distinct tyvars
             { context' <- rnContext cls_doc context
-            ; fds'  <- rnFds cls_doc fds
+            ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
              ; let rn_at = rnTyClDecl (Just cls')
              ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
             ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
@@ -859,21 +867,20 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
                              tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
                               tcdDocs = docs'},
-                 meth_fvs `plusFV` stuff_fvs) }
+                 extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) }
   where
-    cls_doc  = text "In the declaration for class" <+> ppr lcls
+    cls_doc  = ClassDeclCtx lcls
 
 
-bindQTvs :: Maybe Name -> [LHsTyVarBndr RdrName]
+bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName]
          -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
          -> RnM (a, FreeVars)
--- For *associated* type/data family instances (in an instance decl)
--- don't quantify over the already-in-scope type variables
-bindQTvs mb_cls tyvars thing_inside
+bindQTvs doc mb_cls tyvars thing_inside
   | isNothing mb_cls    -- Not associated
-  = bindTyVarsFV tyvars thing_inside
+  = bindTyVarsFV doc tyvars thing_inside
   | otherwise          -- Associated
   = do { let tv_rdr_names = map hsLTyVarLocName tyvars
+                    -- *All* the free vars of the family patterns
 
        -- Check for duplicated bindings
        -- This test is irrelevant for data/type *instances*, where the tyvars
@@ -882,9 +889,10 @@ bindQTvs mb_cls tyvars thing_inside
        ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names)
 
        ; rdr_env <- getLocalRdrEnv
+
        ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names
-       ; (thing, fvs) <- bindLocalNamesFV tv_ns $
-                         thing_inside (zipWith replaceLTyVarName tyvars tv_ns)
+       ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns
+       ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars'
 
        -- Check that the RHS of the decl mentions only type variables
        -- bound on the LHS.  For example, this is not ok
@@ -942,10 +950,21 @@ depAnalTyClDecls ds_w_fvs
     edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
             | (d, fvs) <- ds_w_fvs ]
     get_assoc n = lookupNameEnv assoc_env n `orElse` n
-    assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name) 
-                          | (L _ (ClassDecl { tcdLName = L _ cls_name
-                                            , tcdATs   = ats }) ,_) <- ds_w_fvs
-                          , L _ assoc_decl <- ats ]
+    assoc_env = mkNameEnv assoc_env_list
+    -- We also need to consider data constructor names since they may
+    -- appear in types because of promotion.
+    assoc_env_list = do
+      (L _ d, _) <- ds_w_fvs
+      case d of
+        ClassDecl { tcdLName = L _ cls_name
+                  , tcdATs = ats } -> do
+                       L _ assoc_decl <- ats
+                       return (tcdName assoc_decl, cls_name)
+        TyData { tcdLName = L _ data_name
+               , tcdCons = cons } -> do
+                       L _ dc <- cons
+                       return (unLoc (con_name dc), data_name)
+        _ -> []
 \end{code}
 
 Note [Dependency analysis of type and class decls]
@@ -969,7 +988,7 @@ is jolly confusing.  See Trac #4875
 %*********************************************************
 
 \begin{code}
-rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
+rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
 -- Although, we are processing type patterns here, all type variables will
 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 -- type declaration to which these patterns belong)
@@ -1009,22 +1028,22 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
         -- With Implicit, find the mentioned ones, and use them as binders
        ; new_tvs <- case expl of
                       Implicit -> return (userHsTyVarBndrs mentioned_tvs)
-                      Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs
+                      Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
                                       ; return tvs }
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindTyVarsRn new_tvs $ \new_tyvars -> do
+        ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
        { new_context <- rnContext doc cxt
        ; new_details <- rnConDeclDetails doc details
         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
  where
-    doc = text "In the definition of data constructor" <+> quotes (ppr name)
+    doc = ConDeclCtx name
     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy (HsBoxyTuple liftedTypeKind) tys))
 
-rnConResult :: SDoc
+rnConResult :: HsDocContext
             -> HsConDetails (LHsType Name) [ConDeclField Name]
             -> ResType RdrName
             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
@@ -1044,10 +1063,10 @@ rnConResult doc details (ResTyGADT ty)
                          -- See Note [Sorting out the result type] in RdrHsSyn
                
        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
-              (addErr (badRecResTy doc))
+              (addErr (badRecResTy (docOfHsDocContext doc)))
        ; return (details', ResTyGADT res_ty) }
 
-rnConDeclDetails :: SDoc
+rnConDeclDetails :: HsDocContext
                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 rnConDeclDetails doc (PrefixCon tys)
index 3607170..df6008b 100644 (file)
@@ -14,6 +14,7 @@
 module RnTypes ( 
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
+        rnHsKind, rnLHsKind, rnLHsMaybeKind,
        rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields,
         rnIPName,
 
@@ -22,7 +23,10 @@ module RnTypes (
        checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
 
        -- Splice related stuff
-       rnSplice, checkTH
+       rnSplice, checkTH,
+
+        -- Binding related stuff
+        bindTyVarsRn, bindTyVarsFV
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -33,7 +37,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
 import DynFlags
 import HsSyn
 import RdrHsSyn                ( extractHsRhoRdrTyVars )
-import RnHsSyn         ( extractHsTyNames )
+import RnHsSyn         ( extractHsTyNames, extractHsTyVarBndrNames_s )
 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import TcRnMonad
@@ -50,7 +54,7 @@ import BasicTypes     ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
                          Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
-import Control.Monad   ( unless )
+import Control.Monad   ( unless, zipWithM )
 
 #include "HsVersions.h"
 \end{code}
@@ -65,7 +69,7 @@ to break several loop.
 %*********************************************************
 
 \begin{code}
-rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 rnHsTypeFVs doc_str ty  = do
     ty' <- rnLHsType doc_str ty
     return (ty', extractHsTyNames ty')
@@ -74,12 +78,12 @@ rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.
 rnHsSigType doc_str ty
-  = rnLHsType (text "In the type signature for" <+> doc_str) ty
+  = rnLHsType (TypeSigCtx doc_str) ty
 
 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
 -- Rename the type in an instance or standalone deriving decl
 rnLHsInstType doc_str ty 
-  = do { ty' <- rnLHsType doc_str ty
+  = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty
        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
        ; return ty' }
   where
@@ -96,12 +100,28 @@ rnHsType is here because we call it from loadInstDecl, and I didn't
 want a gratuitous knot.
 
 \begin{code}
-rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
-rnLHsType doc = wrapLocM (rnHsType doc)
-
-rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
-
-rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
+rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
+           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc)
+
+rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsType = rnLHsTyKi True
+rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name)
+rnLHsKind = rnLHsTyKi False
+rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name))
+rnLHsMaybeKind _ Nothing = return Nothing
+rnLHsMaybeKind doc (Just k) = do
+  k' <- rnLHsKind doc k
+  return (Just k')
+
+rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name)
+rnHsType = rnHsTyKi True
+rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name)
+rnHsKind = rnHsTyKi False
+
+rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name)
+
+rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
@@ -118,120 +138,141 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
 
     rnForAll doc Implicit tyvar_bndrs ctxt ty
 
-rnHsType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
-  = do {       -- Explicit quantification.
+rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars 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 mentioned   = extractHsRhoRdrTyVars ctxt tau
              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
-       ; warnUnusedForAlls (in_type_doc $$ doc) forall_tyvars mentioned
+       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
 
        ; -- rnForAll does the rest
          rnForAll doc Explicit forall_tyvars ctxt tau }
 
-rnHsType _ (HsTyVar tyvar) = do
-    tyvar' <- lookupOccRn tyvar
-    return (HsTyVar tyvar')
+rnHsTyKi isType _ (HsTyVar rdr_name) = do
+  -- We use lookupOccRn in kinds because all the names are in
+  -- TcClsName, and we don't want to look in DataName.
+  name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name
+  return (HsTyVar name)
 
 -- If we see (forall a . ty), without foralls on, the forall will give
 -- a sensible error message, but we don't want to complain about the dot too
 -- Hence the jiggery pokery with ty1
-rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
-  = setSrcSpan loc $ 
+rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
+  = ASSERT ( isType ) setSrcSpan loc $ 
     do { ops_ok <- xoptM Opt_TypeOperators
        ; op' <- if ops_ok
-                then lookupOccRn op 
+                then lookupPromotedOccRn op
                 else do { addErr (opTyErr op ty)
                         ; return (mkUnboundName op) }  -- Avoid double complaint
        ; let l_op' = L loc op'
        ; fix <- lookupTyFixityRn l_op'
        ; ty1' <- rnLHsType doc ty1
        ; ty2' <- rnLHsType doc ty2
-       ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
+       ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' }
 
-rnHsType doc (HsParTy ty) = do
-    ty' <- rnLHsType doc ty
+rnHsTyKi isType doc (HsParTy ty) = do
+    ty' <- rnLHsTyKi isType doc ty
     return (HsParTy ty')
 
-rnHsType doc (HsBangTy b ty)
-  = do { ty' <- rnLHsType doc ty
+rnHsTyKi isType doc (HsBangTy b ty)
+  = ASSERT ( isType ) do { ty' <- rnLHsType doc ty
        ; return (HsBangTy b ty') }
 
-rnHsType doc (HsRecTy flds)
-  = do { flds' <- rnConDeclFields doc flds
+rnHsTyKi isType doc (HsRecTy flds)
+  = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds
        ; return (HsRecTy flds') }
 
-rnHsType doc (HsFunTy ty1 ty2) = do
-    ty1' <- rnLHsType doc ty1
+rnHsTyKi isType doc (HsFunTy ty1 ty2) = do
+    ty1' <- rnLHsTyKi isType doc ty1
        -- Might find a for-all as the arg of a function type
-    ty2' <- rnLHsType doc ty2
+    ty2' <- rnLHsTyKi isType doc ty2
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
 
        -- Check for fixity rearrangements
-    mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
-
-rnHsType doc (HsListTy ty) = do
-    ty' <- rnLHsType doc ty
+    if isType
+      then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+      else return (HsFunTy ty1' ty2')
+
+rnHsTyKi isType doc listTy@(HsListTy ty) = do
+    poly_kinds <- xoptM Opt_PolyKinds
+    unless (poly_kinds || isType) (addErr (polyKindsErr listTy))
+    ty' <- rnLHsTyKi isType doc ty
     return (HsListTy ty')
 
-rnHsType doc (HsKindSig ty k)
-  = do { kind_sigs_ok <- xoptM Opt_KindSignatures
+rnHsTyKi isType doc (HsKindSig ty k)
+  = ASSERT ( isType ) do { 
+       ; kind_sigs_ok <- xoptM Opt_KindSignatures
        ; unless kind_sigs_ok (addErr (kindSigErr ty))
        ; ty' <- rnLHsType doc ty
-       ; return (HsKindSig ty' k) }
+       ; k' <- rnLHsKind doc k
+       ; return (HsKindSig ty' k') }
 
-rnHsType doc (HsPArrTy ty) = do
+rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do
     ty' <- rnLHsType doc ty
     return (HsPArrTy ty')
 
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy tup_con tys) = do
-    tys' <- mapM (rnLHsType doc) tys
+rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
+    poly_kinds <- xoptM Opt_PolyKinds
+    unless (poly_kinds || isType) (addErr (polyKindsErr tupleTy))
+    tys' <- mapM (rnLHsTyKi isType doc) tys
     return (HsTupleTy tup_con tys')
 
-rnHsType doc (HsAppTy ty1 ty2) = do
-    ty1' <- rnLHsType doc ty1
-    ty2' <- rnLHsType doc ty2
+rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
+    ty1' <- rnLHsTyKi isType doc ty1
+    ty2' <- rnLHsTyKi isType doc ty2
     return (HsAppTy ty1' ty2')
 
-rnHsType doc (HsIParamTy n ty) = do
+rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do
     ty' <- rnLHsType doc ty
     n' <- rnIPName n
     return (HsIParamTy n' ty')
 
-rnHsType doc (HsEqTy ty1 ty2) = do
+rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do
     ty1' <- rnLHsType doc ty1
     ty2' <- rnLHsType doc ty2
     return (HsEqTy ty1' ty2')
 
-rnHsType _ (HsSpliceTy sp _ k)
-  = do { (sp', fvs) <- rnSplice sp     -- ToDo: deal with fvs
+rnHsTyKi isType _ (HsSpliceTy sp _ k)
+  = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp   -- ToDo: deal with fvs
        ; return (HsSpliceTy sp' fvs k) }
 
-rnHsType doc (HsDocTy ty haddock_doc) = do
+rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do
     ty' <- rnLHsType doc ty
     haddock_doc' <- rnLHsDoc haddock_doc
     return (HsDocTy ty' haddock_doc')
 
 #ifndef GHCI
-rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
+rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
 #else
-rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
+rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq
                                       ; rnHsType doc (unLoc ty) }
 #endif
-rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty)
+rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty)
+rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi"
+
+rnHsTyKi isType doc (HsExplicitListTy k tys) = 
+  ASSERT( isType )
+  do tys' <- mapM (rnLHsType doc) tys
+     return (HsExplicitListTy k tys')
+
+rnHsTyKi isType doc (HsExplicitTupleTy kis tys) =
+  ASSERT( isType )
+  do tys' <- mapM (rnLHsType doc) tys
+     return (HsExplicitTupleTy kis tys')
 
 --------------
-rnLHsTypes :: SDoc -> [LHsType RdrName]
+rnLHsTypes :: HsDocContext -> [LHsType RdrName]
            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
 \end{code}
 
 
 \begin{code}
-rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
+rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
         -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
@@ -244,17 +285,41 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
        -- of kind *.
 
 rnForAll doc exp forall_tyvars ctxt ty
-  = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
+  = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
     new_ctxt <- rnContext doc ctxt
     new_ty <- rnLHsType doc ty
     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
        -- Retain the same implicit/explicit flag as before
        -- so that we can later print it correctly
 
-rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
+bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName]
+             -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+             -> RnM (a, FreeVars)
+bindTyVarsFV doc tyvars thing_inside
+  = bindTyVarsRn doc tyvars $ \ tyvars' ->
+    do { (res, fvs) <- thing_inside tyvars'
+       ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) }
+
+bindTyVarsRn ::  HsDocContext -> [LHsTyVarBndr RdrName]
+             -> ([LHsTyVarBndr Name] -> RnM a)
+             -> RnM a
+-- Haskell-98 binding of type variables; e.g. within a data type decl
+bindTyVarsRn doc tyvar_names enclosed_scope
+  = bindLocatedLocalsRn located_tyvars $ \ names ->
+    do { kind_sigs_ok <- xoptM Opt_KindSignatures
+       ; unless (null kinded_tyvars || kind_sigs_ok)
+           (mapM_ (addErr . kindSigErr) kinded_tyvars)
+       ; tyvar_names' <- zipWithM replace tyvar_names names
+       ; enclosed_scope tyvar_names' }
+  where
+    replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc
+    located_tyvars = hsLTyVarLocNames tyvar_names
+    kinded_tyvars  = [n | L _ (KindedTyVar n _ _) <- tyvar_names]
+
+rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
 rnConDeclFields doc fields = mapM (rnField doc) fields
 
-rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
+rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name)
 rnField doc (ConDeclField name ty haddock_doc)
   = do { new_name <- lookupLocatedTopBndrRn name
        ; new_ty <- rnLHsType doc ty
@@ -269,10 +334,10 @@ rnField doc (ConDeclField name ty haddock_doc)
 %*********************************************************
 
 \begin{code}
-rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
+rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name)
 rnContext doc = wrapLocM (rnContext' doc)
 
-rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
+rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name)
 rnContext' doc ctxt = mapM (rnLHsType doc) ctxt
 
 rnIPName :: IPName RdrName -> RnM (IPName Name)
@@ -311,10 +376,10 @@ mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
           -> Name -> Fixity -> LHsType Name -> LHsType Name 
           -> RnM (HsType Name)
 
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
   = do  { fix2 <- lookupTyFixityRn op2
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
-                     (\t1 t2 -> HsOpTy t1 op2 t2)
+                     (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
                      (unLoc op2) fix2 ty21 ty22 loc2 }
 
 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
index 9af757c..7e3b44c 100644 (file)
@@ -78,7 +78,8 @@ import Literal                ( litIsTrivial )
 import Demand          ( StrictSig, increaseStrictSigArity )
 import Name            ( getOccName, mkSystemVarName )
 import OccName         ( occNameString )
-import Type            ( isUnLiftedType, Type )
+import Type            ( isUnLiftedType, Type, sortQuantVars )
+import Kind            ( kiVarsOfKinds )
 import BasicTypes      ( Arity )
 import UniqSupply
 import Util
@@ -996,22 +997,13 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
        -- whose level is greater than the destination level
        -- These are the ones we are going to abstract out
 abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs
-  = map zap $ uniq $ sortLe le 
+  = map zap $ uniq $ sortQuantVars  -- IA0_NOTE: centralizing sorting on variables
        [var | fv <- varSetElems fvs
             , var <- absVarsOf id_env fv
             , abstract_me var ]
        -- NB: it's important to call abstract_me only on the OutIds the
        -- come from absVarsOf (not on fv, which is an InId)
   where
-       -- Sort the variables so the true type variables come first;
-       -- the tyvars scope over Ids and coercion vars
-    v1 `le` v2 = case (is_tv v1, is_tv v2) of
-                  (True, False) -> True
-                  (False, True) -> False
-                  _             -> v1 <= v2    -- Same family
-
-    is_tv v = isTyVar v 
-
     uniq :: [Var] -> [Var]
        -- Remove adjacent duplicates; the sort will have brought them together
     uniq (v1:v2:vs) | v1 == v2  = uniq (v2:vs)
@@ -1036,7 +1028,9 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
        -- variables
        --
        -- Also, if x::a is an abstracted variable, then so is a; that is,
-       --      we must look in x's type
+       -- we must look in x's type. What's more, if a mentions kind variables,
+       -- we must also return those.
+       -- 
        -- And similarly if x is a coercion variable.
 absVarsOf id_env v 
   | isId v    = [av2 | av1 <- lookup_avs v
@@ -1047,7 +1041,9 @@ absVarsOf id_env v
                        Just (abs_vars, _) -> abs_vars
                        Nothing            -> [v]
 
-    add_tyvars v = v : varSetElems (varTypeTyVars v)
+    add_tyvars v = v : (varSetElems tyvars ++ varSetElems kivars)
+    tyvars = varTypeTyVars v
+    kivars = kiVarsOfKinds (map tyVarKind (varSetElems tyvars))
 \end{code}
 
 \begin{code}
index 1fc8a58..6a0820c 100644 (file)
@@ -1383,7 +1383,7 @@ abstractFloats main_tvs body_env body
           ; return (subst', (NonRec poly_id poly_rhs)) }
       where
        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
-       tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+       tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
        
                -- Abstract only over the type variables free in the rhs
                -- wrt which the new binding is abstracted.  But the naive
@@ -1422,7 +1422,7 @@ abstractFloats main_tvs body_env body
                -- If you ever want to be more selective, remember this bizarre case too:
                --      x::a = x
                -- Here, we must abstract 'x' over 'a'.
-        tvs_here = main_tvs
+        tvs_here = sortQuantVars main_tvs
 
     mk_poly tvs_here var
       = do { uniq <- getUniqueM
@@ -1745,18 +1745,21 @@ mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts
 mkCase1 _dflags scrut case_bndr alts   -- Identity case
   | all identity_alt alts
   = do { tick (CaseIdentity case_bndr)
-       ; return (re_cast scrut) }
+       ; return (re_cast scrut rhs1) }
   where
-    identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
+    identity_alt (con, args, rhs) = check_eq con args rhs
 
-    check_eq DEFAULT       _    (Var v)   = v == case_bndr
-    check_eq (LitAlt lit') _    (Lit lit) = lit == lit'
-    check_eq (DataAlt con) args rhs       = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
-                                        || rhs `cheapEqExpr` Var case_bndr
-    check_eq _ _ _ = False
+    check_eq con           args (Cast e co) | not (any (`elemVarSet` tyCoVarsOfCo co) args)
+        {- See Note [RHS casts] -}          = check_eq con args e
+    check_eq _             _    (Var v)     = v == case_bndr
+    check_eq (LitAlt lit') _    (Lit lit)   = lit == lit'
+    check_eq (DataAlt con) args rhs         = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
+    check_eq _             _    _           = False
 
     arg_tys = map Type (tyConAppArgs (idType case_bndr))
 
+        -- Note [RHS casts]
+        -- ~~~~~~~~~~~~~~~~
        -- We've seen this:
        --      case e of x { _ -> x `cast` c }
        -- And we definitely want to eliminate this case, to give
@@ -1766,12 +1769,11 @@ mkCase1 _dflags scrut case_bndr alts    -- Identity case
        -- if (all identity_alt alts) holds.
        -- 
        -- Don't worry about nested casts, because the simplifier combines them
-    de_cast (Cast e _) = e
-    de_cast e         = e
 
-    re_cast scrut = case head alts of
-                       (_,_,Cast _ co) -> Cast scrut co
-                       _               -> scrut
+    ((_,_,rhs1):_) = alts
+
+    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
+    re_cast scrut _             = scrut
 
 --------------------------------------------------
 --     3. Merge Identical Alternatives
index 1f60781..6f811a9 100644 (file)
@@ -987,8 +987,13 @@ simplCoercionF env co cont
     simpl_co co (CoerceIt g cont)
        = simpl_co new_co cont
      where
-       new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1
-       [g0, g1] = decomposeCo 2 g
+       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
+       -- g1 :: s1 ~# t1
+       -- g2 :: s2 ~# t2
+       new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2
+       [_reflk, g1, g2] = decomposeCo 3 g
+            -- Remember, (~#) :: forall k. k -> k -> *
+            -- so it takes *three* arguments, not two
 
     simpl_co co cont
        = seqCo co `seq` rebuild env (Coercion co) cont
index 97ba4e8..0a94b2b 100644 (file)
@@ -255,6 +255,7 @@ addLocalFamInst home_fie famInst = do
     -- If there are any conflicts, we should probably error
     -- But, if we're allowed to overwrite and the conflict is in the home FIE,
     -- then overwrite instead of error.
+    traceTc "checkForConflicts" (ppr conflicts $$ ppr famInst $$ ppr inst_envs)
     isGHCi <- getIsGHCi
     case conflicts of
         dup : _ ->  case (isGHCi, home_conflicts) of
index 62690a5..e6943ea 100644 (file)
@@ -287,9 +287,14 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
                -- Check that it has the right shape:
                --      ((w,s1) .. sn)
                -- where the si do not mention w
-          ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && 
-                     not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
+           ; _bogus <- unifyType corner_ty (mkTyVarTy w_tv)
+          ; checkTc (not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
                     (badFormFun i tup_ty')
+     -- JPM: WARNING: this test is utterly bogus; see #5609
+     -- We are not using the coercion returned by the unify;
+     -- and (even more seriously) the w not in arg_tys test is totally
+     -- bogus if there are suspended equality constraints. This code
+     -- needs to be re-architected.
 
           ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s }
 
index ac2fe8c..f12bad4 100644 (file)
@@ -1273,6 +1273,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
           ATyVar {}                 -> False          -- In-scope type variables
           AGlobal {}                -> True           --    are not closed!
           AThing {}                 -> pprPanic "is_closed_id" (ppr name)
+          ANothing {}               -> pprPanic "is_closed_id" (ppr name)
       | otherwise
       = WARN( isInternalName name, ppr name ) True
         -- The free-var set for a top level binding mentions
index 83497a8..8cec0b5 100644 (file)
@@ -21,6 +21,7 @@ import FunDeps
 import qualified TcMType as TcM
 import TcType
 import Type
+import Kind
 import Coercion
 import Class
 import TyCon
@@ -474,28 +475,32 @@ canEq fl eqv ty1 (TyConApp fn tys)
   = do { untch <- getUntouchables 
        ; canEqLeaf untch fl eqv (classify ty1) (FunCls fn tys) }
 
-canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+canEq fl eqv ty1@(TyConApp tc1 tys1) ty2@(TyConApp tc2 tys2)
   | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
   , tc1 == tc2
   , length tys1 == length tys2
   = -- Generate equalities for each of the corresponding arguments
-    do { argeqvs 
+    do { let (kis1, tys1') = span isKind tys1
+             (kis2, tys2') = span isKind tys2
+       ; zipWithM_ (unifyKindTcS ty1 ty2) kis1 kis2
+       ; let kicos = map mkReflCo kis1
+       ; argeqvs
              <- if isWanted fl then
-                    do { argeqvs <- zipWithM newEqVar tys1 tys2
+                    do { argeqvs <- zipWithM newEqVar tys1' tys2'
                        ; setEqBind eqv
-                         (mkTyConAppCo tc1 (map mkEqVarLCo argeqvs))
+                         (mkTyConAppCo tc1 (kicos ++ (map mkEqVarLCo argeqvs)))
                        ; return argeqvs }
                 else if isGivenOrSolved fl then
                     let go_one ty1 ty2 n = do
                           argeqv <- newEqVar ty1 ty2
                           setEqBind argeqv (mkNthCo n (mkEqVarLCo eqv))
                           return argeqv
-                    in zipWith3M go_one tys1 tys2 [0..]
+                    in zipWith3M go_one tys1' tys2' [(length kicos)..]
 
                 else -- Derived 
-                    zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1 tys2
+                    zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1' tys2'
 
-       ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1 tys2 }
+       ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1' tys2' }
 
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
@@ -504,7 +509,8 @@ canEq fl eqv ty1 ty2
   , Nothing <- tcView ty2  -- See Note [Naked given applications]
   , Just (s1,t1) <- tcSplitAppTy_maybe ty1
   , Just (s2,t2) <- tcSplitAppTy_maybe ty2
-    = if isWanted fl 
+    = ASSERT( not (isKind t1) && not (isKind t2) )
+      if isWanted fl 
       then do { eqv1 <- newEqVar s1 s2 
               ; eqv2 <- newEqVar t1 t2 
               ; setEqBind eqv
@@ -772,15 +778,10 @@ canEqLeafOriented :: CtFlavor -> EqVar
                   -> TypeClassifier -> TcType -> TcS CanonicalCts 
 -- First argument is not OtherCls
 canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2         -- cv : F tys1
-  | let k1 = kindAppResult (tyConKind fn) tys1,
-    let k2 = typeKind s2, 
-    not (k1 `compatKind` k2) -- Establish the kind invariant for CFunEqCan
-  = canEqFailure fl eqv
-    -- Eagerly fails, see Note [Kind errors] in TcInteract
-
-  | otherwise 
   = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) )
-    do { (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments
+    do { are_compat <- compatKindTcS k1 k2  -- make sure that the kind are compatible
+       ; unless are_compat (unifyKindTcS (unClassify cls1) s2 k1 k2)
+       ; (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments
                                                  -- cos1 :: xis1 ~ tys1
        ; (xi2, co2, ccs2) <- flatten fl s2       -- Flatten entire RHS
                                                  -- co2  :: xi2 ~ s2
@@ -810,6 +811,10 @@ canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2         -- cv : F tys1
                                   , cc_tyargs = xis1 
                                   , cc_rhs    = xi2 }
        ; return $ ccs `extendCCans` final_cc }
+  where
+    k1 = typeKind (unClassify cls1)
+    k2 = typeKind s2
+
 
 -- Otherwise, we have a variable on the left, so call canEqLeafTyVarLeft
 canEqLeafOriented fl eqv (FskCls tv) s2 
@@ -822,11 +827,9 @@ canEqLeafOriented _ eqv (OtherCls ty1) ty2
 canEqLeafTyVarLeft :: CtFlavor -> EqVar -> TcTyVar -> TcType -> TcS CanonicalCts
 -- Establish invariants of CTyEqCans 
 canEqLeafTyVarLeft fl eqv tv s2       -- cv : tv ~ s2
-  | not (k1 `compatKind` k2) -- Establish the kind invariant for CTyEqCan
-  = canEqFailure fl eqv
-       -- Eagerly fails, see Note [Kind errors] in TcInteract
-  | otherwise
-  = do { (xi2, co, ccs2) <- flatten fl s2  -- Flatten RHS   co : xi2 ~ s2
+  = do { are_compat <- compatKindTcS k1 k2
+       ; unless are_compat (unifyKindTcS (mkTyVarTy tv) s2 k1 k2)
+       ; (xi2, co, ccs2) <- flatten fl s2  -- Flatten RHS   co : xi2 ~ s2
        ; mxi2' <- canOccursCheck fl tv xi2 -- Do an occurs check, and return a possibly
                                            -- unfolded version of the RHS, if we had to 
                                            -- unfold any type synonyms to get rid of tv.
@@ -1041,7 +1044,7 @@ instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))]
 instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
                         , fd_pred1 = d1, fd_pred2 = d2 })
   = do { let tvs = varSetElems qtvs
-       ; tvs' <- mapM instFlexiTcS tvs
+       ; tvs' <- mapM instFlexiTcS tvs  -- IA0_TODO: we might need to do kind substitution
        ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
        ; foldM (do_one subst) [] eqs }
   where 
index ab938d3..68f2714 100644 (file)
@@ -119,7 +119,7 @@ tcClassSigs clas sigs def_methods
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
     tc_sig genop_env (op_names, op_hs_ty)
-      = do { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
+      = do { op_ty <- tcHsType op_hs_ty        -- Class tyvars already in scope
            ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
            where
              f nm | nm `elemNameEnv` genop_env = GenericDM
@@ -127,7 +127,7 @@ tcClassSigs clas sigs def_methods
                   | otherwise                  = NoDM
 
     tc_gen_sig (op_names, gen_hs_ty)
-      = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+      = do { gen_op_ty <- tcHsType gen_hs_ty
            ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
 \end{code}
 
index a5c5526..db25c13 100755 (executable)
@@ -34,7 +34,7 @@ import TcMType
 import TcSimplify
 
 import RnBinds
-import RnEnv
+import RnEnv  
 import RnSource   ( addTcgDUs )
 import HscTypes
 
@@ -474,13 +474,12 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
   = setSrcSpan loc                   $
     addErrCtxt (standaloneCtxt deriv_ty)  $
     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
-       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty
+       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
        ; traceTc "Standalone deriving;" $ vcat
               [ text "tvs:" <+> ppr tvs
               , text "theta:" <+> ppr theta
               , text "cls:" <+> ppr cls
               , text "tys:" <+> ppr inst_tys ]
-       ; checkValidInstance deriv_ty tvs theta cls inst_tys
                -- C.f. TcInstDcls.tcLocalInstDecl1
 
        ; let cls_tys = take (length inst_tys - 1) inst_tys
@@ -494,6 +493,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
 
 ------------------------------------------------------------------
 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
+-- The deriving clause of a data or newtype declaration
 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
                                                   tcdTyVars = tv_names,
                                                   tcdTyPats = ty_pats }))
@@ -541,7 +541,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
        ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
                  (typeFamilyPapErr tc cls cls_tys inst_ty)
 
-       ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
+       ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
   where
        -- Tiresomely we must figure out the "lhs", which is awkward for type families
        -- E.g.   data T a b = .. deriving( Eq )
@@ -553,6 +553,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
     get_lhs Nothing     = do { tc <- tcLookupTyCon tycon_name
                             ; let tvs = tyConTyVars tc
                             ; return (tvs, tc, mkTyVarTys tvs) }
+    -- JPM: to fix
     get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
                             ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
                             ; let (tc, tc_args) = tcSplitTyConApp tc_app
@@ -1111,7 +1112,7 @@ mkNewTypeEqn orig dflags tvs
        ; dfun_name <- new_dfun_name cls tycon
        ; loc <- getSrcSpanM
        ; let spec = DS { ds_loc = loc, ds_orig = orig
-                       , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
+                       , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
                        , ds_cls = cls, ds_tys = inst_tys
                        , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                        , ds_theta =  mtheta `orElse` all_preds
index 48b637b..4fe7ee1 100644 (file)
@@ -14,13 +14,13 @@ module TcEnv(
         -- Global environment
         tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
         tcExtendGlobalValEnv,
-        tcLookupLocatedGlobal,  tcLookupGlobal, 
+        tcLookupLocatedGlobal, tcLookupGlobal, 
         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupInstance,
         
         -- Local environment
-        tcExtendKindEnv, tcExtendKindEnvTvs,
+        tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
         tcExtendGhciEnv, tcExtendLetEnv,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
@@ -32,13 +32,13 @@ module TcEnv(
         tcExtendRecEnv,         -- For knot-tying
 
         -- Rules
-        tcExtendRules,
+         tcExtendRules,
 
         -- Defaults
         tcGetDefaultTys,
 
         -- Global type variables
-        tcGetGlobalTyVars,
+        tcGetGlobalTyVars, zapLclTypeEnv,
 
         -- Template Haskell stuff
         checkWellStaged, tcMetaTy, thLevel, 
@@ -221,36 +221,31 @@ setGlobalTypeEnv tcg_env new_type_env
          ; return (tcg_env { tcg_type_env = new_type_env }) }
 
 
-tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-  -- Given a mixture of Ids, TyCons, Classes, all defined in the
-  -- module being compiled, extend the global environment
-tcExtendGlobalEnv things thing_inside
-  = do { env <- getGblEnv
-       ; let env' = env { tcg_tcs  = [ tc | ATyCon tc <- things,
-                                            not (isClassTyCon tc)]
-                                      ++ tcg_tcs env
-                        , tcg_clss = [ cl | ATyCon tc <- things,
-                                            Just cl <- [tyConClass_maybe tc]]
-                                      ++ tcg_clss env }
-       ; setGblEnv env' $
-            tcExtendGlobalEnvImplicit things thing_inside
-       }
-
 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
   -- Extend the global environment with some TyThings that can be obtained
   -- via implicitTyThings from other entities in the environment.  Examples
   -- are dfuns, famInstTyCons, data cons, etc.
-  -- These TyThings are not added to tcg_tcs or tcg_clss.
+  -- These TyThings are not added to tcg_tcs.
 tcExtendGlobalEnvImplicit things thing_inside
    = do { tcg_env <- getGblEnv
         ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
         ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
         ; setGblEnv tcg_env' thing_inside }
 
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
+  -- module being compiled, extend the global environment
+tcExtendGlobalEnv things thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env }
+       ; setGblEnv env' $
+            tcExtendGlobalEnvImplicit things thing_inside
+       }
+
 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
   -- Same deal as tcExtendGlobalEnv, but for Ids
 tcExtendGlobalValEnv ids thing_inside 
-  = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
+  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
 
 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
 -- Extend the global environments for the type/class knot tying game
@@ -319,6 +314,13 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv
 \end{code}
 
 \begin{code}
+tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r
+tcExtendTcTyThingEnv things thing_inside
+  = updLclEnv upd thing_inside
+  where
+    upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
+    extend env  = extendNameEnvList env things
+
 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
 tcExtendKindEnv things thing_inside
   = updLclEnv upd thing_inside
@@ -442,6 +444,14 @@ tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
 tcExtendGlobalTyVars gtv_var extra_global_tvs
   = do { global_tvs <- readMutVar gtv_var
        ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) }
+
+zapLclTypeEnv :: TcM a -> TcM a
+zapLclTypeEnv thing_inside
+  = do { tvs_var <- newTcRef emptyVarSet 
+       ; let upd env = env { tcl_env = emptyNameEnv
+                           , tcl_rdr = emptyLocalRdrEnv
+                           , tcl_tyvars = tvs_var }
+       ; updLclEnv upd thing_inside }
 \end{code}
 
 
@@ -724,11 +734,15 @@ pprBinders bndrs  = pprWithCommas ppr bndrs
 
 notFound :: Name -> TcM TyThing
 notFound name 
-  = do { (gbl,lcl) <- getEnvs
+  = do { (_gbl,lcl) <- getEnvs
        ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> 
                      ptext (sLit "is not in scope during type checking, but it passed the renamer"),
-                     ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env gbl),
                      ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)]
+                       -- Take case: printing the whole gbl env can
+                       -- cause an infnite loop, in the case where we
+                       -- are in the middle of a recursive TyCon/Class group;
+                       -- so let's just not print it!  Getting a loop here is
+                       -- very unhelpful, because it hides one compiler bug with another
                     ) }
 
 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
index 1835956..5217756 100644 (file)
@@ -45,6 +45,7 @@ import DataCon
 import Name
 import TyCon
 import Type
+import Kind( splitKiTyVars )
 import Coercion
 import Var
 import VarSet
@@ -290,8 +291,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
 
        -- Make sure that the argument and result types have kind '*'
        -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
-       ; unifyKind (typeKind arg2_ty) liftedTypeKind
-       ; unifyKind (typeKind res_ty)  liftedTypeKind
+       ; _ <- unifyKind (typeKind arg2_ty) liftedTypeKind
+       ; _ <- unifyKind (typeKind res_ty)  liftedTypeKind
 
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
        ; co_res <- unifyType op_res_ty res_ty
@@ -646,16 +647,24 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
        -- 
        ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
              is_fixed_tv tv = tv `elemVarSet` fixed_tvs
-             mk_inst_ty tv result_inst_ty 
+             mk_inst_ty subst tv result_inst_ty 
                | is_fixed_tv tv = return result_inst_ty            -- Same as result type
-               | otherwise      = newFlexiTyVarTy (tyVarKind tv)  -- Fresh type, of correct kind
+               | otherwise      = newFlexiTyVarTy (subst (tyVarKind tv))  -- Fresh type, of correct kind
 
        ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
-       ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 
-       ; let rec_res_ty    = TcType.substTy result_inst_env con1_res_ty
+        ; let (con1_r_kvs, con1_r_tvs) = splitKiTyVars con1_tvs
+              n_kinds = length con1_r_kvs
+              (result_inst_r_kis, result_inst_r_tys) = splitAt n_kinds result_inst_tys
+       ; scrut_inst_r_kis <- zipWithM (mk_inst_ty (TcType.substTy (zipTopTvSubst [] []))) con1_r_kvs result_inst_r_kis
+          -- IA0_NOTE: we have to build the kind substitution
+        ; let kind_subst = TcType.substTy (zipTopTvSubst con1_r_kvs scrut_inst_r_kis)
+       ; scrut_inst_r_tys <- zipWithM (mk_inst_ty kind_subst) con1_r_tvs result_inst_r_tys
+
+       ; let scrut_inst_tys = scrut_inst_r_kis ++ scrut_inst_r_tys
+              rec_res_ty    = TcType.substTy result_inst_env con1_res_ty
              con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
-             scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
+              scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
              scrut_ty      = TcType.substTy scrut_subst con1_res_ty
 
         ; co_res <- unifyType rec_res_ty res_ty
index e50d41b..e1ab27c 100644 (file)
@@ -26,7 +26,7 @@ module TcHsSyn (
        -- re-exported from TcMonad
        TcId, TcIdSet, 
 
-       zonkTopDecls, zonkTopExpr, zonkTopLExpr,
+       zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar,
        zonkId, zonkTopBndrs
   ) where
 
@@ -45,6 +45,8 @@ import TcMType
 import Coercion
 import TysPrim
 import TysWiredIn
+import Type
+import Kind
 import DataCon
 import Name
 import NameSet
@@ -189,8 +191,15 @@ It's all pretty boring stuff, because HsSyn is such a large type, and
 the environment manipulation is tiresome.
 
 \begin{code}
-data ZonkEnv = ZonkEnv (TcType -> TcM Type)    -- How to zonk a type
-                       (VarEnv Var)            -- What variables are in scope
+type UnboundTyVarZonker = TcTyVar-> TcM Type 
+       -- How to zonk an unbound type variable
+        -- Note [Zonking the LHS of a RULE]
+
+data ZonkEnv 
+  = ZonkEnv 
+      UnboundTyVarZonker
+      (TyVarEnv TyVar)          -- 
+      (IdEnv Var)              -- What variables are in scope
        -- Maps an Id or EvVar to its zonked version; both have the same Name
        -- Note that all evidence (coercion variables as well as dictionaries)
        --      are kept in the ZonkEnv
@@ -198,21 +207,25 @@ data ZonkEnv = ZonkEnv    (TcType -> TcM Type)    -- How to zonk a type
        -- Is only consulted lazily; hence knot-tying
 
 emptyZonkEnv :: ZonkEnv
-emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
+emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv
 
-extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
-extendZonkEnv (ZonkEnv zonk_ty env) ids 
-  = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
+extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
+extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids 
+  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
 
-extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
-extendZonkEnv1 (ZonkEnv zonk_ty env) id 
-  = ZonkEnv zonk_ty (extendVarEnv env id id)
+extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
+extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id 
+  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
 
-setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
-setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
+extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
+extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
+  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env
+
+setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
+setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
 
 zonkEnvIds :: ZonkEnv -> [Id]
-zonkEnvIds (ZonkEnv _ env) = varEnvElts env
+zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
 
 zonkIdOcc :: ZonkEnv -> TcId -> Id
 -- Ids defined in this module should be in the envt; 
@@ -230,7 +243,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id
 --
 -- Even without template splices, in module Main, the checking of
 -- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv _zonk_ty env) id 
+zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id 
   | isLocalVar id = lookupVarEnv env id `orElse` id
   | otherwise    = id
 
@@ -257,17 +270,30 @@ zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
 -- Works for dictionaries and coercions
 zonkEvBndrX env var
   = do { var' <- zonkEvBndr env var
-       ; return (extendZonkEnv1 env var', var') }
+       ; return (extendIdZonkEnv1 env var', var') }
 
 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
 -- Works for dictionaries and coercions
 -- Does not extend the ZonkEnv
 zonkEvBndr env var 
-  = do { ty' <- zonkTcTypeToType env (varType var)
-       ; return (setVarType var ty') }
+  = do { ty <- zonkTcTypeToType env (varType var)
+       ; return (setVarType var ty) }
 
 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
 zonkEvVarOcc env v = zonkIdOcc env v
+
+zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrsX = mapAccumLM zonkTyBndrX 
+
+zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
+zonkTyBndrX env tv
+  = do { tv' <- zonkTyBndr env tv
+       ; return (extendTyZonkEnv1 env tv', tv') }
+
+zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar
+zonkTyBndr env tv
+  = do { ki <- zonkTcTypeToType env (tyVarKind tv)
+       ; return (setVarType tv ki) }
 \end{code}
 
 
@@ -331,7 +357,7 @@ zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
   = mappM (wrapLocM zonk_ip_bind) binds        `thenM` \ new_binds ->
     let
-       env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
+       env1 = extendIdZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
     in
     zonkTcEvBinds env1 dict_binds      `thenM` \ (env2, new_dict_binds) -> 
     returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
@@ -345,7 +371,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
 zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
 zonkRecMonoBinds env sig_warn binds 
  = fixM (\ ~(_, new_binds) -> do 
-       { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
+       { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
         ; binds' <- zonkMonoBinds env1 sig_warn binds
         ; return (env1, binds') })
 
@@ -425,15 +451,17 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                                 , abs_exports = exports
                                  , abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
-    do { (env1, new_evs) <- zonkEvBndrsX env evs
+    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
        ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
-        do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
+         do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
            ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) } 
        ; sig_warn True (map abe_poly new_exports)
-       ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
+       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
+                          , abs_ev_binds = new_ev_binds
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
   where
     zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
@@ -695,7 +723,8 @@ zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
 zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg 
                                  ; return (env, WpEvApp arg') }
 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
-                              return (env, WpTyLam tv) 
+                              do { (env', tv') <- zonkTyBndrX env tv
+                                ; return (env', WpTyLam tv') }
 zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
                                 ; return (env, WpTyApp ty') }
 zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
@@ -744,7 +773,7 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
   = mappM zonk_branch stmts_w_bndrs    `thenM` \ new_stmts_w_bndrs ->
     let 
        new_binders = concat (map snd new_stmts_w_bndrs)
-       env1 = extendZonkEnv env new_binders
+       env1 = extendIdZonkEnv env new_binders
     in
     zonkExpr env1 mzip_op   `thenM` \ new_mzip ->
     zonkExpr env1 bind_op   `thenM` \ new_bind ->
@@ -763,12 +792,12 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
        ; new_ret_id  <- zonkExpr env ret_id
        ; new_mfix_id <- zonkExpr env mfix_id
        ; new_bind_id <- zonkExpr env bind_id
-       ; let env1 = extendZonkEnv env new_rvs
+       ; let env1 = extendIdZonkEnv env new_rvs
        ; (env2, new_segStmts) <- zonkStmts env1 segStmts
        -- Zonk the ret-expressions in an envt that 
        -- has the polymorphic bindings in the envt
        ; new_rets <- mapM (zonkExpr env2) rets
-       ; return (extendZonkEnv env new_lvs,     -- Only the lvs are needed
+       ; return (extendIdZonkEnv env new_lvs,     -- Only the lvs are needed
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
@@ -796,7 +825,7 @@ zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
     ; return_op' <- zonkExpr env' return_op
     ; bind_op'   <- zonkExpr env' bind_op
     ; liftM_op'  <- zonkExpr env' liftM_op
-    ; let env'' = extendZonkEnv env' (map snd binderMap')
+    ; let env'' = extendIdZonkEnv env' (map snd binderMap')
     ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
                                , trS_by = by', trS_form = form, trS_using = using'
                                , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
@@ -858,7 +887,7 @@ zonk_pat env (WildPat ty)
 
 zonk_pat env (VarPat v)
   = do { v' <- zonkIdBndr env v
-       ; return (extendZonkEnv1 env v', VarPat v') }
+       ; return (extendIdZonkEnv1 env v', VarPat v') }
 
 zonk_pat env (LazyPat pat)
   = do { (env', pat') <- zonkPat env pat
@@ -870,7 +899,7 @@ zonk_pat env (BangPat pat)
 
 zonk_pat env (AsPat (L loc v) pat)
   = do { v' <- zonkIdBndr env v
-       ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
+       ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
        ; return (env', AsPat (L loc v') pat') }
 
 zonk_pat env (ViewPat expr pat ty)
@@ -921,7 +950,7 @@ zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
        ; lit' <- zonkOverLit env lit
        ; e1' <- zonkExpr env e1
        ; e2' <- zonkExpr env e2
-       ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
+       ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
 
 zonk_pat env (CoPat co_fn pat ty) 
   = do { (env', co_fn') <- zonkCoFn env co_fn
@@ -983,35 +1012,21 @@ zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
-  = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
-
-       ; unbound_tv_set <- newMutVar emptyVarSet
-       ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
-       -- We need to gather the type variables mentioned on the LHS so we can 
-       -- quantify over them.  Example:
-       --   data T a = C
-       -- 
-       --   foo :: T a -> Int
-       --   foo C = 1
-       --
-       --   {-# RULES "myrule"  foo C = 1 #-}
-       -- 
-       -- After type checking the LHS becomes (foo a (C a))
-       -- and we do not want to zap the unbound tyvar 'a' to (), because
-       -- that limits the applicability of the rule.  Instead, we
-       -- want to quantify over it!  
-       --
-       -- It's easiest to find the free tyvars here. Attempts to do so earlier
-       -- are tiresome, because (a) the data type is big and (b) finding the 
-       -- free type vars of an expression is necessarily monadic operation.
-       --      (consider /\a -> f @ b, where b is side-effected to a)
-
-       ; new_lhs <- zonkLExpr env_lhs lhs
-       ; new_rhs <- zonkLExpr env_rhs rhs
-
-       ; unbound_tvs <- readMutVar unbound_tv_set
+  = do { unbound_tkv_set <- newMutVar emptyVarSet
+       ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set)
+              -- See Note [Zonking the LHS of a RULE]
+
+       ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars
+
+       ; new_lhs <- zonkLExpr env_inside lhs
+       ; new_rhs <- zonkLExpr env_inside rhs
+
+       ; unbound_tkvs <- readMutVar unbound_tkv_set
+
        ; let final_bndrs :: [RuleBndr Var]
-            final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
+             final_bndrs = map (RuleBndr . noLoc)
+                             (varSetElemsKvsFirst unbound_tkvs)
+                           ++ new_bndrs
 
        ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
   where
@@ -1020,7 +1035,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
    zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
 
    zonk_it env v
-     | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
+     | isId v     = do { v' <- zonkIdBndr env v; return (extendIdZonkEnv1 env v', v') }
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
@@ -1085,7 +1100,7 @@ zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
 zonkEvBinds env binds
   = fixM (\ ~( _, new_binds) -> do
-        { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
+        { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
          ; binds' <- mapBagM (zonkEvBind env1) binds
          ; return (env1, binds') })
   where
@@ -1106,39 +1121,108 @@ zonkEvBind env (EvBind var term)
 %*                                                                     *
 %************************************************************************
 
+Note [Zonking the LHS of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather the type variables mentioned on the LHS so we can 
+quantify over them.  Example:
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo a (C a))
+and we do not want to zap the unbound tyvar 'a' to (), because
+that limits the applicability of the rule.  Instead, we
+want to quantify over it!  
+
+It's easiest to get zonkTvCollecting to gather the free tyvars
+here. Attempts to do so earlier are tiresome, because (a) the data
+type is big and (b) finding the free type vars of an expression is
+necessarily monadic operation. (consider /\a -> f @ b, where b is
+side-effected to a)
+
+And that in turn is why ZonkEnv carries the function to use for
+type variables!
+
+Note [Zonking mutable unbound type or kind variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
+arbitrary type. We know if they are unbound even though we don't carry an
+environment, because at the binding site for a variable we bind the mutable
+var to a fresh immutable one.  So the mutable store plays the role of an
+environment.  If we come across a mutable variable that isn't so bound, it
+must be completely free. We zonk the expected kind to make sure we don't get
+some unbound meta variable as the kind.
+
+Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
+type and kind variables. Consider the following datatype:
+
+  data Phantom a = Phantom Int
+
+The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and
+`k` are unbound variables. We want to zonk this to
+(forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if
+we have a type or a kind variable; for kind variables we just return AnyK (and
+not the ill-kinded Any BOX).
+
 \begin{code}
+mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var
+             -> (TcTyVar -> Type)      -- What to do for an immutable var
+             -> TcTyVar -> TcM TcType
+mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn
+  = zonk_tv
+  where
+    zonk_tv tv 
+     = ASSERT( isTcTyVar tv )
+       case tcTyVarDetails tv of
+         SkolemTv {}    -> return (unbound_ivar_fn tv)
+         RuntimeUnk {}  -> return (unbound_ivar_fn tv)
+         FlatSkol ty    -> zonkType zonk_tv ty
+         MetaTv _ ref   -> do { cts <- readMutVar ref
+                             ; case cts of    
+                                  Flexi -> do { kind <- zonkType zonk_tv (tyVarKind tv)
+                                               ; unbound_mvar_fn (setTyVarKind tv kind) }
+                                  Indirect ty -> zonkType zonk_tv ty }
+
 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
-zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
+zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env)
+  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar)
+  where
+    zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of
+                            Nothing  -> mkTyVarTy tv
+                            Just tv' -> mkTyVarTy tv'
 
 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
 
-zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
+zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
 -- This variant collects unbound type variables in a mutable variable
-zonkTypeCollecting unbound_tv_set
-  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
-  where
-    zonk_unbound_tyvar tv 
-        = do { tv' <- zonkQuantifiedTyVar tv
-            ; tv_set <- readMutVar unbound_tv_set
-            ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
-            ; return (mkTyVarTy tv') }
-
-zonkTypeZapping :: TcType -> TcM Type
+-- Works on both types and kinds
+zonkTvCollecting unbound_tv_set tv
+  = do { poly_kinds <- xoptM Opt_PolyKinds
+       ; if isKiVar tv && not poly_kinds then
+            do { defaultKindVarToStar tv
+               ; return liftedTypeKind }
+         else do
+       { tv' <- zonkQuantifiedTyVar tv
+       ; tv_set <- readMutVar unbound_tv_set
+       ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
+       ; return (mkTyVarTy tv') } }
+
+zonkTypeZapping :: UnboundTyVarZonker
 -- This variant is used for everything except the LHS of rules
 -- It zaps unbound type variables to (), or some other arbitrary type
-zonkTypeZapping ty 
-  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty 
-  where
-       -- Zonk a mutable but unbound type variable to an arbitrary type
-       -- We know it's unbound even though we don't carry an environment,
-       -- because at the binding site for a type variable we bind the
-       -- mutable tyvar to a fresh immutable one.  So the mutable store
-       -- plays the role of an environment.  If we come across a mutable
-       -- type variable that isn't so bound, it must be completely free.
-    zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
-                              ; writeMetaTyVar tv ty
-                              ; return ty }
+-- Works on both types and kinds
+zonkTypeZapping tv
+  = do { let ty = if isKiVar tv
+                  -- ty is actually a kind, zonk to AnyK
+                  then anyKind
+                  else anyTypeOfKind (tyVarKind tv)
+       ; writeMetaTyVar tv ty
+       ; return ty }
+
 
 zonkTcLCoToLCo :: ZonkEnv -> LCoercion -> TcM LCoercion
 zonkTcLCoToLCo env co
index b0ef207..8f1fb54 100644 (file)
@@ -20,11 +20,16 @@ module TcHsType (
                -- Kind checking
        kcHsTyVars, kcHsSigType, kcHsLiftedSigType, 
        kcLHsType, kcCheckLHsType, kcHsContext, kcApps,
-       
-               -- Typechecking kinded types
-       tcHsKindedContext, tcHsKindedType, tcHsBangType,
-       tcTyVarBndrs, dsHsType,
-       tcDataKindSig,
+        kindGeneralizeKind, kindGeneralizeKinds,
+
+               -- Sort checking
+       scDsLHsKind, scDsLHsMaybeKind,
+
+                -- Typechecking kinded types
+       tcHsType, tcCheckHsType,
+        tcHsKindedContext, tcHsKindedType, tcHsBangType,
+       tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType,
+       tcDataKindSig, tcTyClTyVars,
 
         ExpKind(..), EkCtxt(..), ekConstraint,
         checkExpectedKind,
@@ -42,27 +47,34 @@ import {-# SOURCE #-}       TcSplice( kcSpliceType )
 import HsSyn
 import RnHsSyn
 import TcRnMonad
+import RnEnv   ( polyKindsErr )
+import TcHsSyn ( mkZonkTcTyVar )
 import TcEnv
 import TcMType
 import TcUnify
 import TcIface
 import TcType
 import {- Kind parts of -} Type
-import Kind ( isConstraintKind )
+import Kind
 import Var
 import VarSet
 import TyCon
+import DataCon ( DataCon, dataConUserType )
+import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
 import Class
+import RdrName ( rdrNameSpace, nameRdrName )
 import Name
 import NameSet
 import TysWiredIn
 import BasicTypes
 import SrcLoc
-import DynFlags ( ExtensionFlag( Opt_ConstraintKinds ) )
+import DynFlags ( ExtensionFlag( Opt_ConstraintKinds, Opt_PolyKinds ) )
 import Util
 import UniqSupply
 import Outputable
+import BuildTyCl ( buildPromotedDataTyCon )
 import FastString
+import Control.Monad ( unless )
 \end{code}
 
 
@@ -163,34 +175,37 @@ tcHsSigTypeNC ctxt hs_ty
          -- The kind is checked by checkValidType, and isn't necessarily
          -- of kind * in a Template Haskell quote eg [t| Maybe |]
        ; ty <- tcHsKindedType kinded_ty
-       ; checkValidType ctxt ty        
+       ; checkValidType ctxt ty
        ; return ty }
 
-tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type])
+-- Like tcHsType, but takes an expected kind
+tcCheckHsType :: LHsType Name -> Kind -> TcM Type
+tcCheckHsType hs_ty exp_kind
+  = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind EkUnk) -- JPM add context
+       ; ty <- tcHsKindedType kinded_ty
+       ; return ty }
+
+tcHsType :: LHsType Name -> TcM Type
+-- kind check and desugar
+-- no validity checking because of knot-tying
+tcHsType hs_ty
+  = do { (kinded_ty, _) <- kc_lhs_type hs_ty
+       ; ty <- tcHsKindedType kinded_ty
+       ; return ty }
+
+tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type])
 -- Typecheck an instance head.  We can't use 
 -- tcHsSigType, because it's not a valid user type.
-tcHsInstHead (L loc hs_ty)
+tcHsInstHead ctxt lhs_ty@(L loc hs_ty)
   = setSrcSpan loc   $ -- No need for an "In the type..." context
                         -- because that comes from the caller
-    kc_ds_inst_head hs_ty
-  where
-    kc_ds_inst_head ty = case splitHsClassTy_maybe cls_ty of
-        Just _ -> do -- Kind-checking first
-          (tvs, ctxt, cls_ty) <- kcHsTyVars tv_names $ \ tv_names' -> do
-            ctxt' <- mapM kcHsLPredType ctxt
-            cls_ty' <- kc_check_hs_type cls_ty ekConstraint
-               -- The body of a forall is usually lifted, but in an instance
-               -- head we only allow something of kind Constraint.
-            return (tv_names', ctxt', cls_ty')
-          -- Now desugar the kind-checked type
-          let Just (cls_name, tys) = splitHsClassTy_maybe cls_ty
-          tcTyVarBndrs tvs  $ \ tvs' -> do
-            ctxt' <- dsHsTypes ctxt
-            clas <- tcLookupClass cls_name
-            tys' <- dsHsTypes tys
-            return (tvs', ctxt', clas, tys')
-        _ -> failWithTc (ptext (sLit "Malformed instance type"))
-      where (tv_names, ctxt, cls_ty) = splitHsForAllTy ty
+    do { kinded_ty <- kc_check_hs_type hs_ty ekConstraint
+       ; ty <- ds_type kinded_ty
+       ; let (tvs, theta, tau) = tcSplitSigmaTy ty
+       ; case getClassPredTys_maybe tau of
+           Nothing          -> failWithTc (ptext (sLit "Malformed instance type"))
+           Just (clas,tys)  -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys
+                                  ; return (tvs, theta, clas, tys) } }
 
 tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
 -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
@@ -219,7 +234,7 @@ tc_hs_deriv tv_names ty
   = kcHsTyVars tv_names                 $ \ tv_names' ->
     do  { cls_kind <- kcClass cls_name
         ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys
-        ; tcTyVarBndrs tv_names'        $ \ tyvars ->
+        ; tcTyVarBndrsKindGen tv_names'        $ \ tyvars ->
     do  { arg_tys <- dsHsTypes tys
         ; cls <- tcLookupClass cls_name
         ; return (tyvars, cls, arg_tys) }}
@@ -249,7 +264,7 @@ tcHsVectInst ty
 \begin{code}
 kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name)
        -- Used for type signatures
-kcHsSigType ty              = addKcTypeCtxt ty $ kcTypeType ty
+kcHsSigType ty              = addKcTypeCtxt ty $ kcArgType ty
 kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty
 
 tcHsKindedType :: LHsType Name -> TcM Type
@@ -261,6 +276,7 @@ tcHsKindedType hs_ty = dsHsType hs_ty
 
 tcHsBangType :: LHsType Name -> TcM Type
 -- Permit a bang, but discard it
+-- Input type has already been kind-checked
 tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty
 tcHsBangType ty                    = tcHsKindedType ty
 
@@ -287,7 +303,7 @@ kcLiftedType ty = kc_check_lhs_type ty ekLifted
     
 ---------------------------
 kcTypeType :: LHsType Name -> TcM (LHsType Name)
--- The type ty must be a *type*, but it can be lifted or 
+-- The type ty must be a *type*, but it can be lifted or
 -- unlifted or an unboxed tuple.
 kcTypeType ty = kc_check_lhs_type ty ekOpen
 
@@ -297,6 +313,11 @@ kcArgs what tys kind
              | (ty,n) <- tys `zip` [1..] ]
 
 ---------------------------
+kcArgType :: LHsType Name -> TcM (LHsType Name)
+-- The type ty must be an *arg* *type* (lifted or unlifted)
+kcArgType ty = kc_check_lhs_type ty ekArg
+
+---------------------------
 kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name)
 kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_check_lhs_type ty kind
 
@@ -333,7 +354,8 @@ kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind
 
 -- This is the general case: infer the kind and compare
 kc_check_hs_type ty exp_kind
-  = do { (ty', act_kind) <- kc_hs_type ty
+  = do { traceTc "kc_check_hs_type" (ppr ty)
+        ; (ty', act_kind) <- kc_hs_type ty
                -- Add the context round the inner check only
                -- because checkExpectedKind already mentions
                -- 'ty' by name in any error message
@@ -361,7 +383,8 @@ kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type ty)
 kc_lhs_type :: LHsType Name -> TcM (LHsType Name, TcKind)
 kc_lhs_type (L span ty)
   = setSrcSpan span $
-    do { (ty', kind) <- kc_hs_type ty
+    do { traceTc "kc_lhs_type" (ppr ty)
+       ; (ty', kind) <- kc_hs_type ty
        ; return (L span ty', kind) }
 
 -- kc_hs_type *returns* the kind of the type, rather than taking an expected
@@ -383,9 +406,7 @@ kc_hs_type (HsTyVar name)
   -- Special case for the unit tycon so it benefits from kind overloading
   | name == tyConName unitTyCon
   = kc_hs_type (HsTupleTy (HsBoxyTuple placeHolderKind) [])
-  | otherwise = do
-    kind <- kcTyVar name
-    return (HsTyVar name, kind)
+  | otherwise = kcTyVar name
 
 kc_hs_type (HsListTy ty) = do
     ty' <- kcLiftedType ty
@@ -396,13 +417,14 @@ kc_hs_type (HsPArrTy ty) = do
     return (HsPArrTy ty', liftedTypeKind)
 
 kc_hs_type (HsKindSig ty k) = do
-    ty' <- kc_check_lhs_type ty (EK k EkKindSig)
-    return (HsKindSig ty' k, k)
+    k' <- scDsLHsKind k
+    ty' <- kc_check_lhs_type ty (EK k' EkKindSig)
+    return (HsKindSig ty' k, k')
 
 kc_hs_type (HsTupleTy (HsBoxyTuple _) tys)
   = do { fact_tup_ok <- xoptM Opt_ConstraintKinds
        ; k <- if fact_tup_ok
-              then newKindVar
+              then newMetaKindVar
               else return liftedTypeKind
        ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k
        ; return (HsTupleTy (HsBoxyTuple k) tys', k) }
@@ -421,10 +443,14 @@ kc_hs_type (HsFunTy ty1 ty2) = do
     ty2' <- kcTypeType ty2
     return (HsFunTy ty1' ty2', liftedTypeKind)
 
-kc_hs_type (HsOpTy ty1 op ty2) = do
-    op_kind <- addLocM kcTyVar op
-    ([ty1',ty2'], res_kind) <- kcApps op op_kind [ty1,ty2]
-    return (HsOpTy ty1' op ty2', res_kind)
+kc_hs_type (HsOpTy ty1 (_, l_op@(L loc op)) ty2) = do
+    (wop, op_kind) <- kcTyVar op
+    ([ty1',ty2'], res_kind) <- kcApps l_op op_kind [ty1,ty2]
+    let op' = case wop of
+                HsTyVar name -> (WpKiApps [], L loc name)
+                HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name)
+                _ -> panic "kc_hs_type HsOpTy"
+    return (HsOpTy ty1' op' ty2', res_kind)
 
 kc_hs_type (HsAppTy ty1 ty2) = do
     let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
@@ -448,17 +474,22 @@ kc_hs_type (HsCoreTy ty)
 kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names         $ \ tv_names' ->
     do { ctxt' <- kcHsContext context
-       ; ty'   <- kcLiftedType ty
+       ; (ty', k)  <- kc_lhs_type ty
             -- The body of a forall is usually a type, but in principle
             -- there's no reason to prohibit *unlifted* types.
             -- In fact, GHC can itself construct a function with an
             -- unboxed tuple inside a for-all (via CPR analyis; see 
-            -- typecheck/should_compile/tc170)
+            -- typecheck/should_compile/tc170).
+             --
+             -- Moreover in instance heads we get forall-types with
+             -- kind Constraint.  
             --
-            -- Still, that's only for internal interfaces, which aren't
-            -- kind-checked, so we only allow liftedTypeKind here
+            -- Really we should check that it's a type of value kind
+             -- {*, Constraint, #}, but I'm not doing that yet
+             -- Example that should be rejected:  
+             --          f :: (forall (a:*->*). a) Int
 
-       ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
+       ; return (HsForAllTy exp tv_names' ctxt' ty', k) }
 
 kc_hs_type (HsBangTy b ty)
   = do { (ty', kind) <- kc_lhs_type ty
@@ -482,6 +513,17 @@ kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type"        -- Eliminated by renamer
 kc_hs_type (HsDocTy ty _)
   = kc_hs_type (unLoc ty) 
 
+kc_hs_type (HsExplicitListTy _ tys) 
+  = do { ty_k_s <- mapM kc_lhs_type tys
+       ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s
+       ; return (HsExplicitListTy kind (map fst ty_k_s), mkListTy kind) }
+kc_hs_type (HsExplicitTupleTy _ tys) = do
+  ty_k_s <- mapM kc_lhs_type tys
+  return ( HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)
+         , mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s))
+
+kc_hs_type (HsWrapTy {}) = panic "kc_hs_type HsWrapTy"  -- it means we kind checked something twice
+
 ---------------------------
 kcApps :: Outputable a
        => a 
@@ -526,16 +568,42 @@ kcHsLPredType :: LHsType Name -> TcM (LHsType Name)
 kcHsLPredType pred = kc_check_lhs_type pred ekConstraint
 
 ---------------------------
-kcTyVar :: Name -> TcM TcKind
-kcTyVar name = do      -- Could be a tyvar or a tycon
-    traceTc "lk1" (ppr name)
-    thing <- tcLookup name
-    traceTc "lk2" (ppr name <+> ppr thing)
-    case thing of 
-        ATyVar _ ty             -> return (typeKind ty)
-        AThing kind             -> return kind
-        AGlobal (ATyCon tc)     -> return (tyConKind tc)
-        _                       -> wrongThingErr "type" thing name
+kcTyVar :: Name -> TcM (HsType Name, TcKind)
+-- See Note [Type checking recursive type and class declarations]
+-- in TcTyClsDecls
+kcTyVar name         -- Could be a tyvar, a tycon, or a datacon
+  = do { traceTc "lk1" (ppr name)
+       ; thing <- tcLookup name
+       ; traceTc "lk2" (ppr name <+> ppr thing)
+       ; case thing of
+           ATyVar _ ty           -> wrap_mono (typeKind ty)
+           AThing kind           -> wrap_poly kind
+           AGlobal (ATyCon tc)   -> wrap_poly (tyConKind tc)
+           AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly
+           _                     -> wrongThingErr "type" thing name }
+  where
+    wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind)
+                        ; return (HsTyVar name, kind) }
+    wrap_poly kind
+      | null kvs = wrap_mono kind
+      | otherwise
+      = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind)
+           ; kvs' <- mapM (const newMetaKindVar) kvs
+           ; let ki = substKiWith kvs kvs' ki_body
+           ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) }
+      where (kvs, ki_body) = splitForAllTys kind
+
+-- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon
+kcDataCon :: DataCon -> TcM TcKind
+kcDataCon dc = do
+  let ty = dataConUserType dc
+  unless (isPromotableType ty) $ promoteErr dc ty
+  let ki = promoteType ty
+  traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki)
+  return ki
+  where
+    promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type")
+      <+> quotes (ppr ty) <+> ptext (sLit "is not promotable"))
 
 kcClass :: Name -> TcM TcKind
 kcClass cls = do       -- Must be a class
@@ -554,22 +622,51 @@ kcClass cls = do  -- Must be a class
 %*                                                                     *
 %************************************************************************
 
-The type desugarer
-
-       * Transforms from HsType to Type
-       * Zonks any kinds
-
-It cannot fail, and does no validity checking, except for 
-structural matters, such as
+Note [Desugaring types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:
+
+  * It transforms from HsType to Type
+
+  * It zonks any kinds.  The returned type should have no mutable kind
+    or type variables (hence returning Type not TcType):
+      - any unconstrained kind variables are defaulted to AnyK just 
+        as in TcHsSyn. 
+      - there are no mutable type variables because we are 
+        kind-checking a type
+    Reason: the returned type may be put in a TyCon or DataCon where
+    it will never subsequently be zonked.
+
+You might worry about nested scopes:
+        ..a:kappa in scope..
+            let f :: forall b. T '[a,b] -> Int
+In this case, f's type could have a mutable kind variable kappa in it;
+and we might then default it to AnyK when dealing with f's type
+signature.  But we don't expect this to happen because we can't get a
+lexically scoped type variable with a mutable kind variable in it.  A
+delicate point, this.  If it becomes an issue we might need to
+distinguish top-level from nested uses.
+
+Moreover
+  * it cannot fail, 
+  * it does no unifications
+  * it does no validity checking, except for structural matters, such as
        (a) spurious ! annotations.
        (b) a class used as a type
 
 \begin{code}
+
+zonkTcKindToKind :: TcKind -> TcM Kind
+-- When zonking a TcKind to a kind we instantiate kind variables to AnyK
+zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy)
+
 dsHsType :: LHsType Name -> TcM Type
 -- All HsTyVarBndrs in the intput type are kind-annotated
+-- See Note [Desugaring types]
 dsHsType ty = ds_type (unLoc ty)
 
 ds_type :: HsType Name -> TcM Type
+-- See Note [Desugaring types]
 ds_type ty@(HsTyVar _)
   = ds_app ty []
 
@@ -599,7 +696,10 @@ ds_type (HsTupleTy hs_con tys) = do
     con <- case hs_con of
         HsUnboxedTuple -> return UnboxedTuple
         HsBoxyTuple kind -> do
-          kind' <- zonkTcKindToKind kind
+          -- Here we use zonkTcKind instead of zonkTcKindToKind because pairs
+          -- are a special case: we use them both for types (eg. (Int, Bool))
+          -- and for constraints (eg. (Show a, Eq a))
+          kind' <- zonkTcKind kind
           case () of
             _ | kind' `eqKind` constraintKind -> return ConstraintTuple
             _ | kind' `eqKind` liftedTypeKind -> return BoxedTuple
@@ -615,10 +715,8 @@ ds_type (HsFunTy ty1 ty2) = do
     tau_ty2 <- dsHsType ty2
     return (mkFunTy tau_ty1 tau_ty2)
 
-ds_type (HsOpTy ty1 (L span op) ty2) = do
-    tau_ty1 <- dsHsType ty1
-    tau_ty2 <- dsHsType ty2
-    setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
+ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) =
+    setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2])
 
 ds_type ty@(HsAppTy _ _)
   = ds_app ty []
@@ -633,7 +731,7 @@ ds_type (HsEqTy ty1 ty2) = do
     return (mkEqPred (tau_ty1, tau_ty2))
 
 ds_type (HsForAllTy _ tv_names ctxt ty)
-  = tcTyVarBndrs tv_names               $ \ tyvars -> do
+  = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do
     theta <- mapM dsHsType (unLoc ctxt)
     tau <- dsHsType ty
     return (mkSigmaTy tyvars theta tau)
@@ -642,16 +740,51 @@ ds_type (HsDocTy ty _)  -- Remove the doc comment
   = dsHsType ty
 
 ds_type (HsSpliceTy _ _ kind) 
-  = do { kind' <- zonkTcKindToKind kind
+  = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) 
+                           kind
+                     -- See Note [Kind of a type splice]
        ; newFlexiTyVarTy kind' }
 
 ds_type (HsQuasiQuoteTy {}) = panic "ds_type"  -- Eliminated by renamer
 ds_type (HsCoreTy ty)       = return ty
 
+ds_type (HsExplicitListTy kind tys) = do
+  kind' <- zonkTcKindToKind kind
+  ds_tys <- mapM dsHsType tys
+  return $
+   foldr (\a b -> mkTyConApp (buildPromotedDataTyCon consDataCon) [kind', a, b])
+         (mkTyConApp (buildPromotedDataTyCon nilDataCon) [kind']) ds_tys
+
+ds_type (HsExplicitTupleTy kis tys) = do
+  MASSERT( length kis == length tys )
+  kis' <- mapM zonkTcKindToKind kis
+  tys' <- mapM dsHsType tys
+  return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys')
+
+ds_type (HsWrapTy (WpKiApps kappas) ty) = do
+  tau <- ds_type ty
+  kappas' <- mapM zonkTcKindToKind kappas
+  return (mkAppTys tau kappas')
+
 dsHsTypes :: [LHsType Name] -> TcM [Type]
 dsHsTypes arg_tys = mapM dsHsType arg_tys
 \end{code}
 
+Note [Kind of a type splice]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these terms, each with TH type splice inside:
+     [| e1 :: Maybe $(..blah..) |]
+     [| e2 :: $(..blah..) |]
+When kind-checking the type signature, we'll kind-check the splice
+$(..blah..); we want to give it a kind that can fit in any context,
+as if $(..blah..) :: forall k. k.  
+
+In the e1 example, the context of the splice fixes kappa to *.  But
+in the e2 example, we'll desugar the type, zonking the kind unification
+variables as we go.  When we encournter the unconstrained kappa, we
+want to default it to '*', not to AnyK.
+
+
 Help functions for type applications
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -668,15 +801,22 @@ ds_app ty tys = do
                           return (mkAppTys fun_ty arg_tys)
 
 ds_var_app :: Name -> [Type] -> TcM Type
-ds_var_app name arg_tys = do
-    thing <- tcLookup name
-    case thing of
-       ATyVar _ ty         -> return (mkAppTys ty arg_tys)
-       AGlobal (ATyCon tc) -> return (mkTyConApp tc arg_tys)
-       _                   -> wrongThingErr "type" thing name
-\end{code}
+-- See Note [Type checking recursive type and class declarations]
+-- in TcTyClsDecls
+ds_var_app name arg_tys 
+  | isTvNameSpace (rdrNameSpace (nameRdrName name))
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATyVar _ ty -> return (mkAppTys ty arg_tys)
+          _           -> wrongThingErr "type" thing name }
+
+  | otherwise
+  = do { thing <- tcLookupGlobal name
+       ; case thing of
+           ATyCon tc   -> return (mkTyConApp tc arg_tys)
+           ADataCon dc -> return (mkTyConApp (buildPromotedDataTyCon dc) arg_tys) 
+          _           -> wrongThingErr "type" (AGlobal thing) name }
 
-\begin{code}
 addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
        -- Wrap a context around only if we want to show that contexts.  
        -- Omit invisble ones and ones user's won't grok
@@ -692,6 +832,20 @@ typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty)
 %*                                                                     *
 %************************************************************************
 
+Note [Kind-checking kind-polymorphic types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+  f :: forall (f::k -> *) a. f a -> Int
+
+Here, the [LHsTyVarBndr Name] of the forall type will be [f,a], where
+  a is a  UserTyVar   -> type variable without kind annotation
+  f is a  KindedTyVar -> type variable with kind annotation
+
+If were were to allow binding sites for kind variables, thus
+  f :: forall @k (f :: k -> *) a. f a -> Int
+then we'd also need
+  k is a   UserKiVar   -> kind variable (they don't need annotation,
+                          since we only have BOX for a super kind)
 
 \begin{code}
 kcHsTyVars :: [LHsTyVarBndr Name] 
@@ -703,33 +857,141 @@ kcHsTyVars tvs thing_inside
        ; 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 (UserTyVar name _)  = UserTyVar name <$> newKindVar
-kcHsTyVar tv@(KindedTyVar {}) = return tv
+-- Return a *kind-annotated* binder, whose PostTcKind is
+-- initialised with a kind variable.
+-- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind 
+-- in it. We aren't yet sure whether the binder is a *type* variable or a *kind*
+-- variable. See Note [Kind-checking kind-polymorphic types]
+--
+-- If the variable is already in scope return it, instead of introducing a new
+-- one. This can occur in 
+--   instance C (a,b) where
+--     type F (a,b) c = ...
+-- Here a,b will be in scope when processing the associated type instance for F.
+kcHsTyVar tyvar = do in_scope <- getInLocalScope
+                     if in_scope (hsTyVarName tyvar)
+                      then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar)
+                              return (UserTyVar (tyVarName inscope_tyvar)
+                                (tyVarKind inscope_tyvar)) 
+                       else kcHsTyVar' tyvar
+    where
+        kcHsTyVar' (UserTyVar name _)        = UserTyVar name <$> newMetaKindVar
+        kcHsTyVar' (KindedTyVar name kind _) = do
+          kind' <- scDsLHsKind kind
+          return (KindedTyVar name kind kind')
 
 ------------------
-tcTyVarBndrs :: [LHsTyVarBndr Name]    -- Kind-annotated binders, which need kind-zonking
-            -> ([TyVar] -> TcM r)
-            -> TcM r
+tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking
+             -> ([TyVar] -> TcM r)
+             -> TcM r
 -- Used when type-checking types/classes/type-decls
 -- Brings into scope immutable TyVars, not mutable ones that require later zonking
+-- Fix #5426: avoid abstraction over kinds containing # or (#)
 tcTyVarBndrs bndrs thing_inside = do
-    tyvars <- mapM (zonk . unLoc) bndrs
+    tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs
     tcExtendTyVarEnv tyvars (thing_inside tyvars)
   where
-    zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind
-                                   ; return (mkTyVar name kind') }
-    zonk (KindedTyVar name kind) = return (mkTyVar name kind)
+    zonk (name, kind)
+      = do { kind' <- zonkTcKind kind
+           ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)"))
+           ; return (mkTyVar name kind') }
+
+tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r
+-- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside
+-- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)]
+tcTyVarBndrsKindGen bndrs thing_inside
+  = do { let kinds = map (hsTyVarKind . unLoc) bndrs
+       ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds
+       ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds
+             ktvs = kvs ++ tyvars     -- See Note [Kinds of quantified type variables]
+       ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars))
+       ; tcExtendTyVarEnv ktvs (thing_inside ktvs) }
+\end{code}
+
+Note [Kinds of quantified type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcTyVarBndrsKindGen quantifies over a specified list of type variables,
+*and* over the kind variables mentioned in the kinds of those tyvars.
+
+Note that we must zonk those kinds (obviously) but less obviously, we
+must return type variables whose kinds are zonked too. Example
+    (a :: k7)  where  k7 := k9 -> k9
+We must return
+    [k9, a:k9->k9]
+and NOT 
+    [k9, a:k7]
+Reason: we're going to turn this into a for-all type, 
+   forall k9. forall (a:k7). blah
+which the type checker will then instantiate, and instantiate does not
+look through unification variables!  
+
+Hence using zonked_kinds when forming 'tyvars'.
+
+\begin{code}
+tcTyClTyVars :: Name -> [LHsTyVarBndr Name]    -- LHS of the type or class decl
+             -> ([TyVar] -> Kind -> TcM a) -> TcM a
+-- tcTyClTyVars T [a,b] calls thing_inside with
+-- [k1,k2,a,b] (k2 -> *)  where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
+--
+-- No need to freshen the k's because they are just skolem 
+-- constants here, and we are at top level anyway.
+tcTyClTyVars tycon tyvars thing_inside
+  = do { thing <- tcLookup tycon
+       ; let { kind =
+                 case thing of
+                   AThing kind -> kind
+                   _ -> panic "tcTyClTyVars"
+                     -- We only call tcTyClTyVars during typechecking in
+                     -- TcTyClDecls, where the local env is extended with
+                     -- the generalized_env (mapping Names to AThings).
+             ; (kvs, body) = splitForAllTys kind
+             ; (kinds, res) = splitKindFunTysN (length names) body
+             ; names = hsLTyVarNames tyvars
+             ; tvs = zipWith mkTyVar names kinds
+             ; all_vs = kvs ++ tvs }
+       ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) }
+
+-- Used when generalizing binders and type family patterns
+-- It takes a kind from the type checker (like `k0 -> *`), and returns the 
+-- final, kind-generalized kind (`forall k::BOX. k -> *`)
+kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind])
+-- INVARIANT: the returned kinds are zonked, and
+--            mention the returned kind variables
+kindGeneralizeKinds kinds 
+  = do { -- Quantify over kind variables free in
+         -- the kinds, and *not* in the environment
+       ; zonked_kinds <- mapM zonkTcKind kinds
+       ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked
+       ; let kvs_to_quantify = tyVarsOfTypes zonked_kinds 
+                               `minusVarSet` gbl_tvs
+
+       ; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify)
+                zonkQuantifiedTyVars kvs_to_quantify
+
+         -- Zonk the kinds again, to pick up either the kind 
+         -- variables we quantify over, or *, depending on whether
+         -- zonkQuantifiedTyVars decided to generalise (which in
+         -- turn depends on PolyKinds)
+       ; final_kinds <- mapM zonkTcKind zonked_kinds
+
+       ; traceTc "generalizeKind" (    ppr kinds <+> ppr kvs_to_quantify
+                                   <+> ppr kvs   <+> ppr final_kinds)
+       ; return (kvs, final_kinds) }
+
+kindGeneralizeKind :: TcKind -> TcM ( [KindVar]  -- these were flexi kind vars
+                                    , Kind )     -- this is the old kind where flexis got zonked
+kindGeneralizeKind kind = do
+  (kvs, [kind']) <- kindGeneralizeKinds [kind]
+  return (kvs, kind')
 
 -----------------------------------
-tcDataKindSig :: Maybe Kind -> TcM [TyVar]
+tcDataKindSig :: Kind -> TcM [TyVar]
 -- GADT decls can have a (perhaps partial) kind signature
 --     e.g.  data T :: * -> * -> * where ...
 -- This function makes up suitable (kinded) type variables for 
 -- the argument kinds, and checks that the result kind is indeed *.
 -- We use it also to make up argument type variables for for data instances.
-tcDataKindSig Nothing = return []
-tcDataKindSig (Just kind)
+tcDataKindSig kind
   = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
        ; span <- getSrcSpanM
        ; us   <- newUniqueSupply 
@@ -932,12 +1194,22 @@ data EkCtxt  = EkUnk             -- Unknown context
              | EkIParam         -- Implicit parameter type
              | EkFamInst        -- Family instance
 
+instance Outputable ExpKind where
+  ppr (EK k _) = ptext (sLit "Expected kind:") <+> ppr k
 
-ekLifted, ekOpen, ekConstraint :: ExpKind
+ekLifted, ekOpen, ekArg, ekConstraint :: ExpKind
 ekLifted     = EK liftedTypeKind EkUnk
 ekOpen       = EK openTypeKind   EkUnk
+ekArg        = EK argTypeKind    EkUnk
 ekConstraint = EK constraintKind EkUnk
 
+unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind
+unifyKinds fun act_kinds = do
+  kind <- newMetaKindVar
+  let exp_kind arg_no = EK kind (EkArg fun arg_no)
+  mapM_ (\(arg_no, (ty, act_kind)) -> checkExpectedKind ty act_kind (exp_kind arg_no)) (zip [1..] act_kinds)
+  return kind
+
 checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM ()
 -- A fancy wrapper for 'unifyKind', which tries
 -- to give decent error messages.
@@ -945,8 +1217,9 @@ checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM ()
 -- checks that the actual kind act_kind is compatible
 --      with the expected kind exp_kind
 -- The first argument, ty, is used only in the error message generation
-checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do
-    (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind)
+checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do
+    traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek)
+    (_errs, mb_r) <- tryTc (unifyKind act_kind exp_kind)
     case mb_r of
         Just _  -> return ()  -- Unification succeeded
         Nothing -> do
@@ -962,8 +1235,8 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do
                n_exp_as = length exp_as
                n_act_as = length act_as
 
-               (env1, tidy_exp_kind) = tidyKind env0 exp_kind
-               (env2, tidy_act_kind) = tidyKind env1 act_kind
+               (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind
+               (env2, tidy_act_kind) = tidyOpenKind env1 act_kind
 
                err | n_exp_as < n_act_as     -- E.g. [Maybe]
                    = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments")
@@ -1005,6 +1278,100 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do
 \end{code}
 
 %************************************************************************
+%*                                                                      *
+        Sort checking kinds
+%*                                                                      *
+%************************************************************************
+
+scDsLHsKind converts a user-written kind to an internal, sort-checked kind.
+It does sort checking and desugaring at the same time, in one single pass.
+It fails when the kinds are not well-formed (eg. data A :: * Int), or if there
+are non-promotable or non-fully applied kinds.
+
+\begin{code}
+scDsLHsKind :: LHsKind Name -> TcM Kind
+scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $
+                  sc_ds_lhs_kind k
+
+scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind)
+scDsLHsMaybeKind Nothing  = return Nothing
+scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k
+                               return (Just k')
+
+sc_ds_lhs_kind :: LHsKind Name -> TcM Kind
+sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki)
+
+-- The main worker
+sc_ds_hs_kind :: HsKind Name -> TcM Kind
+sc_ds_hs_kind k@(HsTyVar _)   = sc_ds_app k []
+sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k []
+
+sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki
+
+sc_ds_hs_kind (HsFunTy ki1 ki2) =
+  do kappa_ki1 <- sc_ds_lhs_kind ki1
+     kappa_ki2 <- sc_ds_lhs_kind ki2
+     return (mkArrowKind kappa_ki1 kappa_ki2)
+
+sc_ds_hs_kind (HsListTy ki) =
+  do kappa <- sc_ds_lhs_kind ki
+     checkWiredInTyCon listTyCon
+     return $ mkListTy kappa
+
+sc_ds_hs_kind (HsTupleTy _ kis) =
+  do kappas <- mapM sc_ds_lhs_kind kis
+     checkWiredInTyCon tycon
+     return $ mkTyConApp tycon kappas
+  where tycon = tupleTyCon BoxedTuple (length kis)
+
+-- Argument not kind-shaped
+sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k)
+
+-- Special case for kind application
+sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
+sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis)
+sc_ds_app (HsTyVar tc)      kis =
+  do arg_kis <- mapM sc_ds_lhs_kind kis
+     sc_ds_var_app tc arg_kis
+sc_ds_app ki                _   = failWithTc (quotes (ppr ki) <+> 
+                                    ptext (sLit "is not a kind constructor"))
+
+-- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar
+sc_ds_var_app :: Name -> [Kind] -> TcM Kind
+-- Special case for * and Constraint kinds
+sc_ds_var_app name arg_kis
+  |    name == liftedTypeKindTyConName
+    || name == constraintKindTyConName = do
+    unless (null arg_kis)
+      (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied"))
+    thing <- tcLookup name
+    case thing of
+      AGlobal (ATyCon tc) -> return (mkTyConApp tc [])
+      _                   -> panic "sc_ds_var_app 1"
+
+-- General case
+sc_ds_var_app name arg_kis = do
+  thing <- tcLookup name
+  case thing of
+    AGlobal (ATyCon tc)
+      | isAlgTyCon tc || isTupleTyCon tc -> do
+      poly_kinds <- xoptM Opt_PolyKinds
+      unless poly_kinds $ addErr (polyKindsErr name)
+      let tc_kind = tyConKind tc
+      case isPromotableKind tc_kind of
+        Just n | n == length arg_kis ->
+          return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis)
+        Just _  -> err tc_kind "is not fully applied"
+        Nothing -> err tc_kind "is not promotable"
+
+    _ -> wrongThingErr "promoted type" thing name
+
+  where err k m = failWithTc (    quotes (ppr name) <+> ptext (sLit "of kind")
+                              <+> quotes (ppr k)    <+> ptext (sLit m))
+
+\end{code}
+
+%************************************************************************
 %*                                                                     *
                Scoped type variables
 %*                                                                     *
index 01bffce..837f382 100644 (file)
@@ -454,16 +454,15 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
                   badBootDeclErr
 
-        ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
-        ; checkValidInstance poly_ty tyvars theta clas inst_tys
+        ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
         ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
 
         -- Next, process any associated types.
         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
         ; idx_tycons0 <- tcExtendTyVarEnv tyvars $
-                        mapAndRecoverM (tcAssocDecl clas mini_env) ats
+                         mapAndRecoverM (tcAssocDecl clas mini_env) ats
 
-        -- Check for misssing associated types and build them
+        -- Check for missing associated types and build them
         -- from their defaults (if available)
         ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
               check_at_instance (fam_tc, defs)
@@ -473,7 +472,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                 | null defs                                  = return (Just (tyConName fam_tc), [])
                  -- No user instance, have defaults ==> instatiate them
                 | otherwise = do
-                    defs' <- forM defs $ \(ATD tvs pat_tys rhs) -> do
+                    defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do
                       let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
                           tvs' = varSetElems (tyVarsOfType rhs')
                           pat_tys' = substTys mini_env_subst pat_tys
@@ -526,6 +525,7 @@ tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon
 tcFamInstDecl top_lvl decl
   = do { -- type family instances require -XTypeFamilies
          -- and can't (currently) be in an hs-boot file
+       ; traceTc "tcFamInstDecl" (ppr decl)
        ; let fam_tc_lname = tcdLName decl
        ; type_families <- xoptM Opt_TypeFamilies
        ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
@@ -551,13 +551,8 @@ tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
 
   -- "type instance"
 tcFamInstDecl1 fam_tc (decl@TySynonym {})
-  = kcFamTyPats decl $ \k_tvs k_typats resKind ->
-    do { -- kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
-                  -- ToDo: the ExpKind could be better
-
-         -- (1) do the work of verifying the synonym
-       ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs })
+  = do { -- (1) do the work of verifying the synonym
+       ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl
 
          -- (2) check the well-formedness of the instance
        ; checkValidFamInst t_typats t_rhs
@@ -571,59 +566,50 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
        }
 
   -- "newtype instance" and "data instance"
-tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
-                                   , tcdCons = cons})
-  = kcFamTyPats decl $ \k_tvs k_typats resKind ->
-    do { -- check that the family declaration is for the right kind
+tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
+                                   , tcdTyVars = tvs, tcdTyPats = Just pats
+                                  , tcdCons = cons})
+  = do { -- Check that the family declaration is for the right kind
          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
-       ; -- (1) kind check the data declaration as usual
-       ; k_decl <- kcDataDecl decl k_tvs
-       ; let k_ctxt = tcdCtxt k_decl
-             k_cons = tcdCons k_decl
-
-         -- result kind must be '*' (otherwise, we have too few patterns)
-       ; resKind' <- zonkTcKindToKind resKind -- Remember: kcFamTyPats supplies unzonked kind!
-       ; checkTc (isLiftedTypeKind resKind') $ tooFewParmsErr (tyConArity fam_tc)
-
-         -- (2) type check indexed data type declaration
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
+         -- Kind check type patterns
+       ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ 
+           \tvs' pats' resultKind -> do
 
-         -- kind check the type indexes and the context
-       { t_typats     <- mapM tcHsKindedType k_typats
-       ; stupid_theta <- tcHsKindedContext k_ctxt
+         -- Check that left-hand side contains no type family applications
+         -- (vanilla synonyms are fine, though, and we checked for
+         -- foralls earlier)
+       { mapM_ checkTyFamFreeness pats'
+         
+         -- Result kind must be '*' (otherwise, we have too few patterns)
+       ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc)
 
-         -- (3) Check that
-         --     (a) left-hand side contains no type family applications
-         --         (vanilla synonyms are fine, though, and we checked for
-         --         foralls earlier)
-       ; mapM_ checkTyFamFreeness t_typats
+       ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt
+       ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons
 
-       ; dataDeclChecks (tcdName decl) new_or_data stupid_theta k_cons
-
-         -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
+         -- Construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats'
        ; let ex_ok = True       -- Existentials ok for type families!
        ; fixM (\ rep_tycon -> do
-             { let orig_res_ty = mkTyConApp fam_tc t_typats
-             ; data_cons <- tcConDecls ex_ok rep_tycon
-                                       (t_tvs, orig_res_ty) k_cons
+             { let orig_res_ty = mkTyConApp fam_tc pats'
+             ; data_cons <- tcConDecls new_or_data ex_ok rep_tycon
+                                       (tvs', orig_res_ty) cons
              ; tc_rhs <-
                  case new_or_data of
                    DataType -> return (mkDataTyConRhs data_cons)
                    NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
-             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-                             h98_syntax NoParentTyCon (Just (fam_tc, t_typats))
+             ; buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs Recursive
+                             h98_syntax NoParentTyCon (Just (fam_tc, pats'))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
                  -- dependency.  (2) They are always valid loop breakers as
                  -- they involve a coercion.
              })
-       }}
-       where
+       } }
+    where
          h98_syntax = case cons of      -- All constructors have same shape
                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
                         _ -> True
@@ -644,9 +630,9 @@ tcAssocDecl clas mini_env (L loc decl)
   
        -- Check that the associated type comes from this class
        ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
-                 (badATErr clas (tyConName at_tc))
+                 (badATErr (className clas) (tyConName at_tc))
 
-       -- See Note [Checking consistent instantiation]
+       -- See Note [Checking consistent instantiation] in TcTyClsDecls
        ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
 
        ; return at_tc }
@@ -914,7 +900,7 @@ tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
   = addErrCtxt (spec_ctxt prag) $
     do  { let name = idName dfun_id
-        ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
+        ; (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
         ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
 
         ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
index 5315c20..a4e8734 100644 (file)
@@ -622,7 +622,8 @@ trySpontaneousEqOneWay eqv gw tv xi
   | not (isSigTyVar tv) || isTyVarTy xi 
   = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts 
                                -- so we have its more specific kind in our hands
-       ; if kxi `isSubKind` tyVarKind tv then
+       ; is_sub_kind <- kxi `isSubKindTcS` tyVarKind tv
+       ; if is_sub_kind then
              solveWithIdentity eqv gw tv xi
          else return SPCantSolve
 {-
@@ -642,18 +643,32 @@ trySpontaneousEqOneWay eqv gw tv xi
 trySpontaneousEqTwoWay :: EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult
 -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
 trySpontaneousEqTwoWay eqv gw tv1 tv2
-  | k1 `isSubKind` k2
-  , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
-  | k2 `isSubKind` k1 
-  = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2)
-  | otherwise -- None is a subkind of the other, but they are both touchable! 
-  = return SPCantSolve
-    -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2)
-    --   ; return SPError }
+  = do { k1_sub_k2 <- k1 `isSubKindTcS` k2
+       ; if k1_sub_k2 && nicer_to_update_tv2
+         then solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
+         else do
+       { k2_sub_k1 <- k2 `isSubKindTcS` k1
+       ; MASSERT( k2_sub_k1 )  -- they were unified in TcCanonical
+       ; solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) } }
   where
     k1 = tyVarKind tv1
     k2 = tyVarKind tv2
     nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
+{-
+-- Previous code below (before kind polymorphism and unification):
+  -- | k1 `isSubKind` k2
+  -- , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
+  -- | k2 `isSubKind` k1 
+  -- = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2)
+  -- | otherwise -- None is a subkind of the other, but they are both touchable! 
+  -- = return SPCantSolve
+  --   -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2)
+  --   --   ; return SPError }
+  -- where
+  --   k1 = tyVarKind tv1
+  --   k2 = tyVarKind tv2
+  --   nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
+-}
 \end{code}
 
 Note [Kind errors] 
index 032516b..3f88cbb 100644 (file)
@@ -24,7 +24,7 @@ module TcMType (
   newFlexiTyVar,
   newFlexiTyVarTy,             -- Kind -> TcM TcType
   newFlexiTyVarTys,            -- Int -> Kind -> TcM [TcType]
-  newKindVar, newKindVars, 
+  newMetaKindVar, newMetaKindVars,
   mkTcTyVarName,
 
   newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
@@ -48,7 +48,7 @@ module TcMType (
   --------------------------------
   -- Checking type validity
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
-  SourceTyCtxt(..), checkValidTheta, 
+  checkValidTheta, 
   checkValidInstHead, checkValidInstance, validDerivPred,
   checkInstTermination, checkValidFamInst, checkTyFamFreeness, 
   arityErr, 
@@ -56,19 +56,18 @@ module TcMType (
 
   --------------------------------
   -- Zonking
-  zonkType, mkZonkTcTyVar, zonkTcPredType, 
+  zonkType, zonkKind, zonkTcPredType, 
   zonkTcTypeCarefully, skolemiseUnboundMetaTyVar,
   zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
-  zonkTcKindToKind, zonkTcKind, 
+  zonkTcKind, defaultKindVarToStar,
   zonkImplication, zonkEvVar, zonkWantedEvVar, zonkFlavoredEvVar,
   zonkWC, zonkWantedEvVars,
   zonkTcTypeAndSubst,
   tcGetGlobalTyVars, 
 
-
-  readKindVar, writeKindVar
+  compatKindTcM, isSubKindTcM
   ) where
 
 #include "HsVersions.h"
@@ -77,6 +76,7 @@ module TcMType (
 import TypeRep
 import TcType
 import Type
+import Kind
 import Class
 import TyCon
 import Var
@@ -102,7 +102,7 @@ import Unique( Unique )
 import Bag
 
 import Control.Monad
-import Data.List        ( (\\) )
+import Data.List        ( (\\), partition )
 \end{code}
 
 
@@ -113,13 +113,13 @@ import Data.List        ( (\\) )
 %************************************************************************
 
 \begin{code}
-newKindVar :: TcM TcKind
-newKindVar = do        { uniq <- newUnique
+newMetaKindVar :: TcM TcKind
+newMetaKindVar = do    { uniq <- newUnique
                ; ref <- newMutVar Flexi
-               ; return (mkTyVarTy (mkKindVar uniq ref)) }
+               ; return (mkTyVarTy (mkMetaKindVar uniq ref)) }
 
-newKindVars :: Int -> TcM [TcKind]
-newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ())
+newMetaKindVars :: Int -> TcM [TcKind]
+newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())
 \end{code}
 
 
@@ -209,17 +209,24 @@ tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty
 tcSuperSkolTyVars :: [TyVar] -> [TcTyVar]
 -- Make skolem constants, but do *not* give them new names, as above
 -- Moreover, make them "super skolems"; see comments with superSkolemTv
-tcSuperSkolTyVars tyvars
-  = [ mkTcTyVar (tyVarName tv) (tyVarKind tv) superSkolemTv
-    | tv <- tyvars ]
-
-tcInstSkolTyVar :: Bool -> TyVar -> TcM TcTyVar
+-- see Note [Kind substitution when instantiating]
+tcSuperSkolTyVars tyvars  -- IA0_NOTE: should be ordered (kind vars first)
+  = kvs' ++ tvs'
+  where
+    (kvs, tvs) = splitKiTyVars tyvars
+    kvs' = [ mkTcTyVar (tyVarName kv) (tyVarKind kv) superSkolemTv
+           | kv <- kvs ]
+    tvs' = [ mkTcTyVar (tyVarName tv) (substTy subst (tyVarKind tv)) superSkolemTv
+           | tv <- tvs ]
+    subst = zipTopTvSubst kvs (map mkTyVarTy kvs')
+
+tcInstSkolTyVar :: Bool -> TvSubst -> TyVar -> TcM TcTyVar
 -- Instantiate the tyvar, using 
 --     * the occ-name and kind of the supplied tyvar, 
 --     * the unique from the monad,
 --     * the location either from the tyvar (skol_info = SigSkol)
 --                     or from the monad (otherwise)
-tcInstSkolTyVar overlappable tyvar
+tcInstSkolTyVar overlappable subst tyvar
   = do { uniq <- newUnique
         ; loc <-  getSrcSpanM
        ; let new_name = mkInternalName uniq occ loc
@@ -227,13 +234,27 @@ tcInstSkolTyVar overlappable tyvar
   where
     old_name = tyVarName tyvar
     occ      = nameOccName old_name
-    kind     = tyVarKind tyvar
+    kind     = substTy subst (tyVarKind tyvar)
 
 tcInstSkolTyVars :: [TyVar] -> TcM [TcTyVar]
-tcInstSkolTyVars tyvars = mapM (tcInstSkolTyVar False) tyvars
+-- Precondition: tyvars should be ordered (kind vars first)
+-- see Note [Kind substitution when instantiating]
+tcInstSkolTyVars tyvars
+  = do { kvs' <- mapM (tcInstSkolTyVar False (mkTopTvSubst [])) kvs
+       ; tvs' <- mapM (tcInstSkolTyVar False (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs
+       ; return (kvs' ++ tvs') }
+  where (kvs, tvs) = splitKiTyVars tyvars
 
 tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
-tcInstSuperSkolTyVars tyvars = mapM (tcInstSkolTyVar True) tyvars
+-- Precondition: tyvars should be ordered (kind vars first)
+-- see Note [Kind substitution when instantiating]
+
+-- JPM: do this with mapAccumLM
+tcInstSuperSkolTyVars tyvars
+  = do { kvs' <- mapM (tcInstSkolTyVar True (mkTopTvSubst [])) kvs
+       ; tvs' <- mapM (tcInstSkolTyVar True (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs
+       ; return (kvs' ++ tvs') }
+  where (kvs, tvs) = splitKiTyVars tyvars
 
 tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
@@ -243,19 +264,40 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
 tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
 -- Make meta SigTv type variables for patten-bound scoped type varaibles
 -- We use SigTvs for them, so that they can't unify with arbitrary types
-tcInstSigTyVars = mapM tcInstSigTyVar
-
-tcInstSigTyVar :: TyVar -> TcM TcTyVar
-tcInstSigTyVar tyvar
-  = do { uniq <- newMetaUnique
-       ; ref <- newMutVar Flexi
-        ; let name = setNameUnique (tyVarName tyvar) uniq
-               -- Use the same OccName so that the tidy-er 
-               -- doesn't rename 'a' to 'a0' etc
-             kind = tyVarKind tyvar
-       ; return (mkTcTyVar name kind (MetaTv SigTv ref)) }
+-- Precondition: tyvars should be ordered (kind vars first)
+-- see Note [Kind substitution when instantiating]
+tcInstSigTyVars tyvars
+  = do { kvs' <- mapM (tcInstSigTyVar (mkTopTvSubst [])) kvs
+       ; tvs' <- mapM (tcInstSigTyVar (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs
+       ; return (kvs' ++ tvs') }
+  where (kvs, tvs) = splitKiTyVars tyvars
+
+tcInstSigTyVar :: TvSubst -> TyVar -> TcM TcTyVar
+tcInstSigTyVar subst tyvar
+  = do { uniq <- newMetaUnique
+       ; ref <- newMutVar Flexi
+       ; let name = setNameUnique (tyVarName tyvar) uniq
+                    -- Use the same OccName so that the tidy-er
+                    -- doesn't rename 'a' to 'a0' etc
+             kind = substTy subst (tyVarKind tyvar)
+       ; return (mkTcTyVar name kind (MetaTv SigTv ref)) }
 \end{code}
 
+Note [Kind substitution when instantiating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we instantiate a bunch of kind and type variables, first we
+expect them to be sorted (kind variables first, then type variables).
+Then we have to instantiate the kind variables, build a substitution
+from old variables to the new variables, then instantiate the type
+variables substituting the original kind.
+
+Exemple: If we want to instantiate
+  [(k1 :: BOX), (k2 :: BOX), (a :: k1 -> k2), (b :: k1)]
+we want
+  [(?k1 :: BOX), (?k2 :: BOX), (?a :: ?k1 -> ?k2), (?b :: ?k1)]
+instead of the buggous
+  [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)]
+
 
 %************************************************************************
 %*                                                                     *
@@ -281,6 +323,7 @@ mkTcTyVarName :: Unique -> FastString -> Name
 -- leaving the un-cluttered names free for user names
 mkTcTyVarName uniq str = mkSysTvName uniq str
 
+-- Works for both type and kind variables
 readMetaTyVar :: TyVar -> TcM MetaDetails
 readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
                      readMutVar (metaTvRef tyvar)
@@ -304,6 +347,7 @@ isFlexiMetaTyVar tv
   | otherwise = return False
 
 --------------------
+-- Works with both type and kind variables
 writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
 -- Write into a currently-empty MetaTyVar
 
@@ -333,20 +377,27 @@ writeMetaTyVarRef tyvar ref ty
        ; writeMutVar ref (Indirect ty) }
 
 -- Everything from here on only happens if DEBUG is on
-  | not (isPredTy tv_kind)   -- Don't check kinds for updates to coercion variables
-  , not (ty_kind `isSubKind` tv_kind)
-  = WARN( True, hang (text "Ill-kinded update to meta tyvar")
-                   2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
-    return ()
-
   | otherwise
   = do { meta_details <- readMutVar ref; 
+       -- Zonk kinds to allow the error check to work
+       ; zonked_tv_kind <- zonkTcKind tv_kind 
+       ; zonked_ty_kind <- zonkTcKind ty_kind
+
+       -- Check for double updates
        ; ASSERT2( isFlexi meta_details, 
                   hang (text "Double update of meta tyvar")
                    2 (ppr tyvar $$ ppr meta_details) )
 
          traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
-       ; writeMutVar ref (Indirect ty) }
+       ; writeMutVar ref (Indirect ty) 
+       ; when (   not (isPredTy tv_kind) 
+                    -- Don't check kinds for updates to coercion variables
+               && not (zonked_ty_kind `isSubKind` zonked_tv_kind))
+       $ WARN( True, hang (text "Ill-kinded update to meta tyvar")
+                        2 (    ppr tyvar <+> text "::" <+> ppr tv_kind 
+                           <+> text ":=" 
+                           <+> ppr ty    <+> text "::" <+> ppr ty_kind) )
+         (return ()) }
   where
     tv_kind = tyVarKind tyvar
     ty_kind = typeKind ty
@@ -373,23 +424,26 @@ newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
 
 tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
 -- Instantiate with META type variables
-tcInstTyVars tyvars
-  = do { tc_tvs <- mapM tcInstTyVar tyvars
-       ; let tys = mkTyVarTys tc_tvs
-       ; return (tc_tvs, tys, zipTopTvSubst tyvars tys) }
-               -- Since the tyvars are freshly made,
-               -- they cannot possibly be captured by
-               -- any existing for-alls.  Hence zipTopTvSubst
-
-tcInstTyVar :: TyVar -> TcM TcTyVar
--- Make a new unification variable tyvar whose Name and Kind 
--- come from an existing TyVar
-tcInstTyVar tyvar
-  = do { uniq <- newMetaUnique
-       ; ref <- newMutVar Flexi
-        ; let name = mkSystemName uniq (getOccName tyvar)
-             kind = tyVarKind tyvar
-       ; return (mkTcTyVar name kind (MetaTv TauTv ref)) }
+tcInstTyVars tyvars = tcInstTyVarsX emptyTvSubst tyvars
+    -- emptyTvSubst has an empty in-scope set, but that's fine here
+    -- Since the tyvars are freshly made, they cannot possibly be
+    -- captured by any existing for-alls.
+
+tcInstTyVarsX :: TvSubst -> [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
+tcInstTyVarsX subst tyvars =
+  do { (subst', tyvars') <- mapAccumLM tcInstTyVar subst tyvars
+     ; return (tyvars', mkTyVarTys tyvars', subst') }
+
+tcInstTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar)
+-- Make a new unification variable tyvar whose Name and Kind come from
+-- an existing TyVar. We substitute kind variables in the kind.
+tcInstTyVar subst tyvar
+  = do  { uniq <- newMetaUnique
+        ; ref <- newMutVar Flexi
+        ; let name   = mkSystemName uniq (getOccName tyvar)
+              kind   = substTy subst (tyVarKind tyvar)
+              new_tv = mkTcTyVar name kind (MetaTv TauTv ref)
+        ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
 \end{code}
 
 
@@ -474,29 +528,37 @@ zonkTcType ty = zonkType zonkTcTyVar ty
 zonkTcTyVar :: TcTyVar -> TcM TcType
 -- Simply look through all Flexis
 zonkTcTyVar tv
-  = ASSERT2( isTcTyVar tv, ppr tv )
+  = ASSERT2( isTcTyVar tv, ppr tv ) do
     case tcTyVarDetails tv of
-      SkolemTv {}   -> return (TyVarTy tv)
-      RuntimeUnk {} -> return (TyVarTy tv)
+      SkolemTv {}   -> zonk_kind_and_return
+      RuntimeUnk {} -> zonk_kind_and_return
       FlatSkol ty   -> zonkTcType ty
       MetaTv _ ref  -> do { cts <- readMutVar ref
                           ; case cts of
-                              Flexi       -> return (TyVarTy tv)
+                              Flexi       -> zonk_kind_and_return
                               Indirect ty -> zonkTcType ty }
+  where
+    zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv
+                              ; return (TyVarTy z_tv) }
+
+zonkTyVarKind :: TyVar -> TcM&