Merge remote-tracking branch 'origin/master' into type-nats
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Wed, 14 Mar 2012 05:15:11 +0000 (22:15 -0700)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Wed, 14 Mar 2012 05:15:11 +0000 (22:15 -0700)
Conflicts:
compiler/coreSyn/CoreLint.lhs
compiler/deSugar/DsBinds.lhs
compiler/hsSyn/HsTypes.lhs
compiler/iface/IfaceType.lhs
compiler/rename/RnHsSyn.lhs
compiler/rename/RnTypes.lhs
compiler/stgSyn/StgLint.lhs
compiler/typecheck/TcHsType.lhs
compiler/utils/ListSetOps.lhs

34 files changed:
1  2 
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsBinds.lhs
compiler/hsSyn/HsTypes.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/TcIface.lhs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysPrim.lhs
compiler/rename/RnTypes.lhs
compiler/stgSyn/StgLint.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcEvidence.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/Kind.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/utils/ListSetOps.lhs

@@@ -742,31 -673,46 +673,56 @@@ lintType ty@(TyConApp tc tys
  lintType (ForAllTy tv ty)
    = do { lintTyBndrKind tv
         ; addInScopeVar tv (lintType ty) }
- ----------------
- lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
 +
 +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
 +
+ \end{code}
+ \begin{code}
+ lintKind :: OutKind -> LintM ()
+ lintKind k = do { sk <- lintType k 
+                 ; unless (isSuperKind sk) 
+                          (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k)
+                                       2 (ptext (sLit "has kind:") <+> ppr sk))) }
+ \end{code}
+ \begin{code}
+ lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
+ lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2
+                        -- or lintarrow "coercion `blah'" k1 k2
+   | isSuperKind k1 
+   = return superKind
+   | otherwise
+   = do { unless (okArrowArgKind k1)    (addErrL (msg (ptext (sLit "argument")) k1))
+        ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result"))   k2))
+        ; return liftedTypeKind }
+   where
+     msg ar k
+       = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar)
+                   2 (ptext (sLit "in") <+> what)
+              , what <+> ptext (sLit "kind:") <+> ppr k ]
+ lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
  lint_ty_app ty k tys 
-   = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
+   = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
  
  ----------------
- lint_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
+ lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
  lint_co_app ty k tys 
-   = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys
-        ; return () }
+   = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys
  
  ----------------
- ----------------
- lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind
- -- (lint_kind_app d fun_kind arg_tys)
 +lintTyLit :: TyLit -> LintM ()
 +lintTyLit (NumTyLit n)
 +  | n >= 0    = return ()
 +  | otherwise = failWithL msg
 +    where msg = ptext (sLit "Negative type literal:") <+> integer n
 +lintTyLit (StrTyLit _) = return ()
 +
+ lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
+ -- (lint_app d fun_kind arg_tys)
  --    We have an application (f arg_ty1 .. arg_tyn),
  --    where f :: fun_kind
  -- Takes care of linting the OutTypes
Simple merge
Simple merge
@@@ -156,18 -153,19 +156,20 @@@ dsHsBind (AbsBinds { abs_tvs = tyvars, 
  dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                     , abs_exports = exports, abs_ev_binds = ev_binds
                     , abs_binds = binds })
+          -- See Note [Desugaring AbsBinds]
    = do  { bind_prs    <- ds_lhs_binds binds
-         ; ds_binds    <- dsTcEvBinds ev_binds
-         ; let core_bind = Rec (fromOL bind_prs)
+         ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs
+                               | (lcl_id, rhs) <- fromOL bind_prs ]
                -- Monomorphic recursion possible, hence Rec
  
++            locals       = map abe_mono exports
              tup_expr     = mkBigCoreVarTup locals
              tup_ty       = exprType tup_expr
--            poly_tup_rhs = mkLams tyvars $ mkLams dicts $
 -                           mkCoreLets (dsTcEvBinds ev_binds) $
++        ; ds_binds <- dsTcEvBinds ev_binds
++      ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
 +                           mkCoreLets ds_binds $
                             Let core_bind $
                             tup_expr
--            locals       = map abe_mono exports
  
        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
  
                                   mkLams tyvars $ mkLams dicts $
                                 mkTupleSelector locals local tup_id $
                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
 -                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
 +                     ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
-                    ; let global' = addIdSpecialisations global rules
+                    ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                              `addIdSpecialisations` rules
+                            -- Kill the INLINE pragma because it applies to
+                            -- the user written (local) function.  The global
+                            -- Id is just the selector.  Hmm.  
                     ; return ((global', rhs) `consOL` spec_binds) }
  
          ; export_binds_s <- mapM mk_bind exports
@@@ -623,15 -637,6 +647,11 @@@ ppr_fun_ty ctxt_prec ty1 ty
      in
      maybeParen ctxt_prec pREC_FUN $
      sep [p1, ptext (sLit "->") <+> p2]
- pabrackets :: SDoc -> SDoc
- pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
- --------------------------
 +
 +--------------------------
 +ppr_tylit :: HsTyLit -> SDoc
 +ppr_tylit (HsNumTy i) = integer i
 +ppr_tylit (HsStrTy s) = text (show s)
  \end{code}
  
  
@@@ -998,38 -998,11 +998,15 @@@ instance Binary IfaceType wher
              putByte bh 3
              put_ bh ag
              put_ bh ah
-     
-         -- Simple compression for common cases of TyConApp
-     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 }
+       = do { putByte bh 4; put_ bh cc; put_ bh tys }
      put_ bh (IfaceTyConApp tc tys)
-       = do { putByte bh 21; put_ bh tc; put_ bh tys }
+       = do { putByte bh 5; put_ bh tc; put_ bh tys }
  
 +    put_ bh (IfaceLitTy n)
 +      = do { putByte bh 30; put_ bh n }
 +
 +
      get bh = do
              h <- getByte bh
              case h of
                3 -> do ag <- get bh
                        ah <- get bh
                        return (IfaceFunTy ag ah)
-               
-                 -- 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) }
+               4 -> do { cc <- get bh; tys <- get bh
+                       ; return (IfaceCoConApp cc tys) }
+               5 -> do { tc <- get bh; tys <- get bh
+                       ; return (IfaceTyConApp tc tys) }
  
 +              30 -> do n <- get bh
 +                       return (IfaceLitTy n)
 +
                _  -> panic ("get IfaceType " ++ show h)
  
 +instance Binary IfaceTyLit where
 +  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n
 +  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n
 +
 +  get bh =
 +    do tag <- getByte bh
 +       case tag of
 +         1 -> do { n <- get bh
 +                 ; return (IfaceNumTyLit n) }
 +         2 -> do { n <- get bh
 +                 ; return (IfaceStrTyLit n) }
 +         _ -> panic ("get IfaceTyLit " ++ show tag)
 +
  instance Binary IfaceTyCon where
-         -- 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 -> 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)
+    put_ bh (IfaceTc ext) = put_ bh ext
+    get bh = liftM IfaceTc (get bh)
  
  instance Binary IfaceCoCon where
     put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
Simple merge
@@@ -17,9 -17,7 +17,8 @@@ module IfaceType 
        IfExtName, IfLclName, IfIPName,
  
          IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
 +        IfaceTyLit(..),
        IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
-       ifaceTyConName,
  
        -- Conversion from Type -> IfaceType
          toIfaceType, toIfaceKind, toIfaceContext,
@@@ -89,24 -86,9 +88,13 @@@ data IfaceType         -- A kind of universa
  type IfacePredType = IfaceType
  type IfaceContext = [IfacePredType]
  
- 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.
 +data IfaceTyLit
 +  = IfaceNumTyLit Integer
 +  | IfaceStrTyLit FastString
 +
+ -- Encodes type constructors, kind constructors
+ -- coercion constructors, the lot
+ newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
  
    -- Coercion constructors
  data IfaceCoCon
@@@ -307,17 -255,11 +263,15 @@@ ppr_tc_app ctxt_prec tc ty
  
  ppr_tc :: IfaceTyCon -> SDoc
  -- Wrap infix type constructors in parens
- ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc)
- ppr_tc tc                = ppr tc
+ ppr_tc tc = parenSymOcc (getOccName (ifaceTyConName tc)) (ppr tc)
  
 +ppr_tylit :: IfaceTyLit -> SDoc
 +ppr_tylit (IfaceNumTyLit n) = integer n
 +ppr_tylit (IfaceStrTyLit n) = text (show n)
 +
  -------------------
  instance Outputable IfaceTyCon where
-   ppr (IfaceIPTc n)  = ppr (IPName n)
-   ppr other_tc       = ppr (ifaceTyConName other_tc)
+   ppr = ppr . ifaceTyConName
  
  instance Outputable IfaceCoCon where
    ppr (IfaceCoAx n)    = ppr n
@@@ -388,40 -322,11 +338,15 @@@ toIfaceCoVar = occNameFS . getOccNam
  
  ----------------
  toIfaceTyCon :: TyCon -> IfaceTyCon
- toIfaceTyCon tc 
-   | isTupleTyCon tc            = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
-   | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
-   | otherwise                = toIfaceTyCon_name (tyConName tc)
+ toIfaceTyCon = toIfaceTyCon_name . tyConName
  
  toIfaceTyCon_name :: Name -> IfaceTyCon
- toIfaceTyCon_name nm
-   | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm
-   = toIfaceWiredInTyCon tc nm
-   | otherwise
-   = IfaceTc nm
- toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
- toIfaceWiredInTyCon tc nm
-   | 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
+ toIfaceTyCon_name = IfaceTc
  
 +toIfaceTyLit :: TyLit -> IfaceTyLit
 +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
 +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
 +
  ----------------
  toIfaceTypes :: [Type] -> [IfaceType]
  toIfaceTypes ts = map toIfaceType ts
Simple merge
Simple merge
Simple merge
Simple merge
@@@ -342,12 -364,6 +365,12 @@@ argTypeKind      = kindTyConType argTyp
  ubxTupleKind     = kindTyConType ubxTupleKindTyCon
  constraintKind   = kindTyConType constraintKindTyCon
  
- typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName tySuperKind)
 +typeNatKind :: Kind
- typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName tySuperKind)
++typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind)
 +
 +typeStringKind :: Kind
++typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind)
 +
  -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
  mkArrowKind :: Kind -> Kind -> Kind
  mkArrowKind k1 k2 = FunTy k1 k2
@@@ -215,67 -218,78 +218,86 @@@ rnHsTyKi isType doc (HsPArrTy ty
  
  -- Unboxed tuples are allowed to have poly-typed arguments.  These
  -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
- rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
-     data_kinds <- xoptM Opt_DataKinds
-     unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
-     tys' <- mapM (rnLHsTyKi isType doc) tys
-     return (HsTupleTy tup_con tys')
+ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
+   = do { data_kinds <- xoptM Opt_DataKinds
+        ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
+        ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
+        ; return (HsTupleTy tup_con tys', fvs) }
  
- rnHsTyKi isType _ tyLit@(HsTyLit t) = do
-     data_kinds <- xoptM Opt_DataKinds
-     unless (data_kinds || isType) (addErr (dataKindsErr tyLit))
-     return (HsTyLit t)
- rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
-     ty1' <- rnLHsTyKi isType doc ty1
-     ty2' <- rnLHsTyKi isType doc ty2
-     return (HsAppTy ty1' ty2')
- rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do
-     ty' <- rnLHsType doc ty
-     n' <- rnIPName n
-     return (HsIParamTy n' ty')
- rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do
-     ty1' <- rnLHsType doc ty1
-     ty2' <- rnLHsType doc ty2
-     return (HsEqTy ty1' ty2')
 +-- 1. Perhaps we should use a separate extension here?
 +-- 2. Check that the integer is positive?
++rnHsTyKi isType _ tyLit@(HsTyLit t)
++  = do { data_kinds <- xoptM Opt_DataKinds
++       ; unless (data_kinds || isType) (addErr (dataKindsErr tyLit))
++       ; return (HsTyLit t, emptyFVs) }
++
+ rnHsTyKi isType doc (HsAppTy ty1 ty2)
+   = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
+        ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
+        ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
+ rnHsTyKi isType doc (HsIParamTy n ty)
+   = ASSERT( isType )
+     do { (ty', fvs) <- rnLHsType doc ty
+        ; n' <- rnIPName n
+        ; return (HsIParamTy n' ty', fvs) }
+ rnHsTyKi isType doc (HsEqTy ty1 ty2) 
+   = ASSERT( isType )
+     do { (ty1', fvs1) <- rnLHsType doc ty1
+        ; (ty2', fvs2) <- rnLHsType doc ty2
+        ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
  
  rnHsTyKi isType _ (HsSpliceTy sp _ k)
-   = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp  -- ToDo: deal with fvs
-        ; return (HsSpliceTy sp' fvs k) }
+   = ASSERT ( isType ) 
+     do { (sp', fvs) <- rnSplice sp    -- ToDo: deal with fvs
+        ; return (HsSpliceTy sp' fvs k, fvs) }
  
- rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do
-     ty' <- rnLHsType doc ty
-     haddock_doc' <- rnLHsDoc haddock_doc
-     return (HsDocTy ty' haddock_doc')
+ rnHsTyKi isType doc (HsDocTy ty haddock_doc) 
+   = ASSERT ( isType )
+     do { (ty', fvs) <- rnLHsType doc ty
+        ; haddock_doc' <- rnLHsDoc haddock_doc
+        ; return (HsDocTy ty' haddock_doc', fvs) }
  
  #ifndef GHCI
  rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
  #else
- rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq
-                                       ; rnHsType doc (unLoc ty) }
+ rnHsTyKi isType doc (HsQuasiQuoteTy qq) 
+   = ASSERT ( isType ) 
+     do { ty <- runQuasiQuoteType qq
+        ; rnHsType doc (unLoc ty) }
  #endif
- rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty)
- rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi"
  
- rnHsTyKi isType doc (HsExplicitListTy k tys) = 
-   ASSERT( isType )
-   do tys' <- mapM (rnLHsType doc) tys
-      return (HsExplicitListTy k tys')
+ rnHsTyKi isType _ (HsCoreTy ty) 
+   = ASSERT ( isType ) 
+     return (HsCoreTy ty, emptyFVs)
+     -- The emptyFVs probably isn't quite right 
+     -- but I don't think it matters
+ rnHsTyKi _ _ (HsWrapTy {}) 
+   = panic "rnHsTyKi"
  
- rnHsTyKi isType doc (HsExplicitTupleTy kis tys) =
-   ASSERT( isType )
-   do tys' <- mapM (rnLHsType doc) tys
-      return (HsExplicitTupleTy kis tys')
+ rnHsTyKi isType doc (HsExplicitListTy k tys)
+   = ASSERT( isType )
+     do { (tys', fvs) <- rnLHsTypes doc tys
+        ; return (HsExplicitListTy k tys', fvs) }
+ rnHsTyKi isType doc (HsExplicitTupleTy kis tys) 
+   = ASSERT( isType )
+     do { (tys', fvs) <- rnLHsTypes doc tys
+        ; return (HsExplicitTupleTy kis tys', fvs) }
+ --------------
+ rnTyVar :: Bool -> RdrName -> RnM Name
+ rnTyVar is_type rdr_name
+   | is_type   = lookupTypeOccRn rdr_name
+   | otherwise = lookupKindOccRn rdr_name
  
 +
  --------------
  rnLHsTypes :: HsDocContext -> [LHsType RdrName]
-            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
- rnLHsTypes doc tys = mapM (rnLHsType doc) tys
+            -> RnM ([LHsType Name], FreeVars)
+ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
  \end{code}
  
  
Simple merge
@@@ -602,61 -596,8 +596,10 @@@ flatten d ctxt t
    = do { (xi, co) <- flatten d ctxt ty'
         ; return (xi,co) } 
  
 +flatten _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi)
 +
  flatten d ctxt (TyVarTy tv)
-   = do { ieqs <- getInertEqs
-        ; let mco = tv_eq_subst (fst ieqs) tv  -- co : v ~ ty
-        ; case mco of -- Done, but make sure the kind is zonked
-            Nothing -> 
-                do { let knd = tyVarKind tv
-                   ; (new_knd,_kind_co) <- flatten d ctxt knd
-                   ; let ty = mkTyVarTy (setVarType tv new_knd)
-                   ; return (ty, mkTcReflCo ty) }
-            -- NB recursive call. 
-            -- Why? See Note [Non-idempotent inert substitution]
-            -- Actually, I think applying the substition just twice will suffice
-            Just (co,ty) -> 
-                do { (ty_final,co') <- flatten d ctxt ty
-                   ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } }  
-   where tv_eq_subst subst tv
-           | Just (ct,co) <- lookupVarEnv subst tv
-           , cc_flavor ct `canRewrite` ctxt
-           = Just (co,cc_rhs ct)
-           | otherwise = Nothing
- \end{code}
- Note [Non-idempotent inert substitution]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- The inert substitution is not idempotent in the broad sense. It is only idempotent in 
- that it cannot rewrite the RHS of other inert equalities any further. An example of such 
- an inert substitution is:
-  [Ś] g1 : ta8 ~ ta4
-  [W] g2 : ta4 ~ a5Fj
- Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on
- an RHS of an equality. Now, imagine a constraint:
-  [W] g3: ta8 ~ Int 
- coming in. If we simply apply once the inert substitution we will get: 
-  [W] g3_1: ta4 ~ Int 
- and because potentially ta4 is untouchable we will try to insert g3_1 in the inert set, 
- getting a panic since the inert only allows ONE equation per LHS type variable (as it 
- should).
- For this reason, when we reach to flatten a type variable, we flatten it recursively, 
- so that we can make sure that the inert substitution /is/ fully applied.
- This insufficient rewriting was the reason for #5668.
- \begin{code}
+   = flattenTyVar d ctxt tv
  
  flatten d ctxt (AppTy ty1 ty2)
    = do { (xi1,co1) <- flatten d ctxt ty1
Simple merge
@@@ -470,19 -468,10 +470,20 @@@ data EvTer
    | EvSuperClass DictId Int      -- n'th superclass. Used for both equalities and
                                   -- dictionaries, even though the former have no
                                   -- selector Id.  We count up from _0_
    | EvKindCast EvVar TcCoercion  -- See Note [EvKindCast]
 -           
 +
 +  | EvLit EvLit                  -- The dictionary for class "NatI"
 +                                 -- Note [EvLit]
 +
    deriving( Data.Data, Data.Typeable)
 +
 +
 +data EvLit
 +  = EvNum Integer
 +  | EvStr FastString
 +    deriving( Data.Data, Data.Typeable)
 +
  \end{code}
  
  Note [EvKindCast] 
Simple merge
Simple merge
@@@ -323,89 -300,173 +300,180 @@@ tc_lhs_type_fresh, to first create a ne
  the expected kind.
  
  \begin{code}
- kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind)
- -- Called from outside: set the context
- kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type_fresh ty)
- kc_lhs_type_fresh :: LHsType Name -> TcM (LHsType Name, TcKind)
- kc_lhs_type_fresh ty =  do
-   kv <- newMetaKindVar
-   r <- kc_lhs_type ty (EK kv (ptext (sLit "Expected")))
-   return (r, kv)
- kc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [LHsType Name]
- kc_lhs_types tys_w_kinds = mapM (uncurry kc_lhs_type) tys_w_kinds
- kc_lhs_type :: LHsType Name -> ExpKind -> TcM (LHsType Name)
- kc_lhs_type (L span ty) exp_kind
+ tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind)
+ tc_infer_lhs_type ty =
+   do { kv <- newMetaKindVar
+      ; r <- tc_lhs_type ty (EK kv (ptext (sLit "Expected")))
+      ; return (r, kv) }
+ tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType
+ tc_lhs_type (L span ty) exp_kind
    = setSrcSpan span $
-     do { traceTc "kc_lhs_type" (ppr ty <+> ppr exp_kind)
-        ; ty' <- kc_hs_type ty exp_kind
-        ; return (L span ty') }
- kc_hs_type :: HsType Name -> ExpKind -> TcM (HsType Name)
- kc_hs_type (HsParTy ty) exp_kind = do
-    ty' <- kc_lhs_type ty exp_kind
-    return (HsParTy ty')
- kc_hs_type (HsTyVar name) exp_kind = do
-    (ty, k) <- kcTyVar name
-    checkExpectedKind ty k exp_kind
-    return ty
- kc_hs_type (HsListTy ty) exp_kind = do
-     ty' <- kcLiftedType ty
-     checkExpectedKind ty liftedTypeKind exp_kind
-     return (HsListTy ty')
- kc_hs_type (HsPArrTy ty) exp_kind = do
-     ty' <- kcLiftedType ty
-     checkExpectedKind ty liftedTypeKind exp_kind
-     return (HsPArrTy ty')
- kc_hs_type (HsKindSig ty sig_k) exp_kind = do
-     sig_k' <- scDsLHsKind sig_k
-     ty' <- kc_lhs_type ty
-              (EK sig_k' (ptext (sLit "An enclosing kind signature specified")))
-     checkExpectedKind ty sig_k' exp_kind
-     return (HsKindSig ty' sig_k)
+     do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind)
+        ; tc_hs_type ty exp_kind }
+ tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType]
+ tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds
+ ------------------------------------------
+ tc_hs_type :: HsType Name -> ExpKind -> TcM TcType
+ tc_hs_type (HsParTy ty)        exp_kind = tc_lhs_type ty exp_kind
+ tc_hs_type (HsDocTy ty _)      exp_kind = tc_lhs_type ty exp_kind
+ tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq"     -- Eliminated by renamer
+ tc_hs_type (HsBangTy {})       _ = panic "tc_hs_type: bang"   -- Unwrapped by con decls
+ tc_hs_type (HsRecTy _)         _ = panic "tc_hs_type: record" -- Unwrapped by con decls
+       -- Record types (which only show up temporarily in constructor 
+       -- signatures) should have been removed by now
+ ---------- Functions and applications
+ tc_hs_type hs_ty@(HsTyVar name) exp_kind
+   = do { (ty, k) <- tcTyVar name
+        ; checkExpectedKind hs_ty k exp_kind
+        ; return ty }
+ tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt)
+   = do { ty1' <- tc_lhs_type ty1 (EK argTypeKind  ctxt)
+        ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt)
+        ; checkExpectedKind ty liftedTypeKind exp_kind
+        ; return (mkFunTy ty1' ty2') }
+ tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind
+   = do { (op', op_kind) <- tcTyVar op
+        ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind
+        ; return (mkNakedAppTys op' tys') }
+          -- mkNakedAppTys: see Note [Zonking inside the knot]
+ tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind
+   = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
+        ; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty
+        ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind
+        ; return (mkNakedAppTys fun_ty' arg_tys') }
+          -- mkNakedAppTys: see Note [Zonking inside the knot]
+ --------- Foralls
+ tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind
+   = tcHsTyVarBndrs hs_tvs $ \ tvs' -> 
+     -- Do not kind-generalise here!  See Note [Kind generalisation]
+     do { ctxt' <- tcHsContext context
+        ; ty'   <- tc_lhs_type ty exp_kind
+            -- Why exp_kind?  See Note [Body kind of forall]
+        ; return (mkSigmaTy tvs' ctxt' ty') }
+ --------- Lists, arrays, and tuples
+ tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind 
+   = do { tau_ty <- tc_lhs_type elt_ty ekLifted
+        ; checkExpectedKind hs_ty liftedTypeKind exp_kind
+        ; checkWiredInTyCon listTyCon
+        ; return (mkListTy tau_ty) }
+ tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind
+   = do { tau_ty <- tc_lhs_type elt_ty ekLifted
+        ; checkExpectedKind hs_ty liftedTypeKind exp_kind
+        ; checkWiredInTyCon parrTyCon
+        ; return (mkPArrTy tau_ty) }
  
  -- See Note [Distinguishing tuple kinds] in HsTypes
- kc_hs_type ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt)
-   | isConstraintOrLiftedKind exp_k -- (NB: not zonking, to avoid left-right bias)
-   = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys exp_k
-        ; return $ if isConstraintKind exp_k
-                     then HsTupleTy HsConstraintTuple tys'
-                     else HsTupleTy HsBoxedTuple      tys' }
+ -- See Note [Inferring tuple kinds]
+ tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt)
+      -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
+   | isConstraintKind exp_k = tc_tuple hs_ty HsConstraintTuple tys exp_kind
+   | isLiftedTypeKind exp_k = tc_tuple hs_ty HsBoxedTuple      tys exp_kind
    | otherwise
-   -- It is not clear from the context if it's * or Constraint, 
-   -- so we infer the kind from the arguments
    = do { k <- newMetaKindVar
-        ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k 
+        ; tau_tys <- tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k)
         ; k' <- zonkTcKind k
-        ; if isConstraintKind k'
-          then do { checkExpectedKind ty k' exp_kind
-                  ; return (HsTupleTy HsConstraintTuple tys') }
-          -- If it's not clear from the arguments that it's Constraint, then
-          -- it must be *. Check the arguments again to give good error messages
+        ; if isConstraintKind k' then
+             finish_tuple hs_ty HsConstraintTuple tau_tys exp_kind
+          else if isLiftedTypeKind k' then
+             finish_tuple hs_ty HsBoxedTuple tau_tys exp_kind
+          else
+             tc_tuple hs_ty HsBoxedTuple tys exp_kind }
+          -- It's not clear what the kind is, so assume *, and
+          -- check the arguments again to give good error messages
           -- in eg. `(Maybe, Maybe)`
-          else do { tys'' <- kcArgs (ptext (sLit "a tuple")) tys liftedTypeKind
-                  ; checkExpectedKind ty liftedTypeKind exp_kind
-                  ; return (HsTupleTy HsBoxedTuple tys'') } }
- {-
- Note that we will still fail to infer the correct kind in this case:
  
-   type T a = ((a,a), D a)
-   type family D :: Constraint -> Constraint
+ tc_hs_type hs_ty@(HsTupleTy tup_sort tys) exp_kind
+   = tc_tuple hs_ty tup_sort tys exp_kind
  
- While kind checking T, we do not yet know the kind of D, so we will default the
- kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
- -}
+ --------- Promoted lists and tuples
+ tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind
+   = do { tks <- mapM tc_infer_lhs_type tys
+        ; let taus = map fst tks
+        ; kind <- unifyKinds (ptext (sLit "In a promoted list")) tks
+        ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind
+        ; return (foldr (mk_cons kind) (mk_nil kind) taus) }
+   where
+     mk_cons k a b = mkTyConApp (buildPromotedDataCon consDataCon) [k, a, b]
+     mk_nil  k     = mkTyConApp (buildPromotedDataCon nilDataCon) [k]
+ tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind
+   = do { tks <- mapM tc_infer_lhs_type tys
+        ; let n          = length tys
+              kind_con   = promotedTupleTyCon   BoxedTuple n
+              ty_con     = promotedTupleDataCon BoxedTuple n
+              (taus, ks) = unzip tks
+              tup_k      = mkTyConApp kind_con ks
+        ; checkExpectedKind hs_ty tup_k exp_kind
+        ; return (mkTyConApp ty_con (ks ++ taus)) }
+ --------- Constraint types
+ tc_hs_type ipTy@(HsIParamTy n ty) exp_kind
+   = do { ty' <- tc_lhs_type ty 
+             (EK liftedTypeKind (ptext (sLit "The type argument of the implicit parameter had")))
+        ; checkExpectedKind ipTy constraintKind exp_kind
+        ; return (mkIPPred n ty') }
+ tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind 
+   = do { (ty1', kind1) <- tc_infer_lhs_type ty1
+        ; (ty2', kind2) <- tc_infer_lhs_type ty2
+        ; checkExpectedKind ty2 kind2
+               (EK kind1 (ptext (sLit "The left argument of the equality predicate had")))
+        ; checkExpectedKind ty constraintKind exp_kind
+        ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) }
+ --------- Misc
+ tc_hs_type (HsKindSig ty sig_k) exp_kind 
+   = do { sig_k' <- tcLHsKind sig_k
+        ; checkExpectedKind ty sig_k' exp_kind
+        ; tc_lhs_type ty
+              (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) }
+ tc_hs_type (HsCoreTy ty) exp_kind
+   = do { checkExpectedKind ty (typeKind ty) exp_kind
+        ; return ty }
+ #ifdef GHCI   /* Only if bootstrapped */
+ -- This looks highly bogus to me
+ tc_hs_type hs_ty@(HsSpliceTy sp fvs _) exp_kind 
+   = do { (ty, kind) <- tcSpliceType sp fvs
+        ; checkExpectedKind hs_ty kind exp_kind
+ --        ; kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) 
+ --                            kind
+ --                     -- See Note [Kind of a type splice]
+        ; return ty }
+ #else
+ tc_hs_type ty@(HsSpliceTy {}) _exp_kind 
+   = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+ #endif
+ tc_hs_type (HsWrapTy {}) _exp_kind 
+   = panic "tc_hs_type HsWrapTy"  -- We kind checked something twice
  
- kc_hs_type ty@(HsTupleTy tup_sort tys) exp_kind
-   = do { tys' <- kcArgs cxt_doc tys arg_kind
-        ; checkExpectedKind ty out_kind exp_kind
-        ; return (HsTupleTy tup_sort tys') }
++tc_hs_type hs_ty@(HsTyLit tl) exp_kind = do
++  let (ty,k) = case tl of
++                 HsNumTy n -> (mkNumLitTy n, typeNatKind)
++                 HsStrTy s -> (mkStrLitTy s,  typeStringKind)
++  checkExpectedKind hs_ty k exp_kind
++  return ty
++
+ ---------------------------
+ tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType
+ -- Invariant: tup_sort is not HsBoxedOrConstraintTuple
+ tc_tuple hs_ty tup_sort tys exp_kind
+   = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind)
+        ; finish_tuple hs_ty tup_sort tau_tys exp_kind }
    where
      arg_kind = case tup_sort of
                   HsBoxedTuple      -> liftedTypeKind
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
Simple merge
@@@ -1577,10 -1547,9 +1575,10 @@@ typeKind (TyConApp tc tys
    = kindAppResult (tyConKind tc) tys
  
  typeKind (AppTy fun arg)      = kindAppResult (typeKind fun) [arg]
 +typeKind (LitTy l)            = typeLiteralKind l
  typeKind (ForAllTy _ ty)      = typeKind ty
  typeKind (TyVarTy tyvar)      = tyVarKind tyvar
- typeKind (FunTy _arg res)
+ typeKind _ty@(FunTy _arg res)
      -- Hack alert.  The kind of (Int -> Int#) is liftedTypeKind (*), 
      --              not unliftedTypKind (#)
      -- The only things that can be after a function arrow are
@@@ -23,14 -32,14 +33,14 @@@ module TypeRep 
          PredType, ThetaType,      -- Synonyms
  
          -- Functions over types
-         mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys,
-         isLiftedTypeKind,
+         mkNakedTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys,
+         isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar,
          
          -- Pretty-printing
-       pprType, pprParendType, pprTypeApp,
+       pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
        pprTyThing, pprTyThingCategory, 
        pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
 -        pprKind, pprParendKind,
 +        pprKind, pprParendKind, pprTyLit,
        Prec(..), maybeParen, pprTcApp, pprTypeNameApp, 
          pprPrefixApp, pprArrowChain, ppr_type,
  
Simple merge