New kind-polymorphic core

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

5 files changed, 58 insertions, 36 deletions

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index d6a71f27..c6ac2b0a 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -17,7 +17,7 @@ module Haddock.Backends.LaTeX (
 import Haddock.Types
 import Haddock.Utils
 import Haddock.GhcUtils
-import Pretty hiding (Doc)
+import Pretty hiding (Doc, quote)
 import qualified Pretty
 
 import GHC
@@ -25,7 +25,6 @@ import OccName
 import Name                 ( isTyConName, nameOccName )
 import RdrName              ( rdrNameOcc, isRdrTc )
 import BasicTypes           ( ipNameName )
-import Outputable           ( Outputable, ppr, showSDoc )
 import FastString           ( unpackFS, unpackLitString )
 
 import qualified Data.Map as Map
@@ -791,10 +790,6 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 -------------------------------------------------------------------------------
 
 
-ppKind :: Outputable a => a -> LaTeX
-ppKind k = text (showSDoc (ppr k))
-
-
 ppBang :: HsBang -> LaTeX
 ppBang HsNoBang = empty
 ppBang _        = char '!' -- Unpacked args is an implementation detail,
@@ -840,6 +835,12 @@ ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode
 ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
 ppFunLhType  unicode ty = ppr_mono_ty pREC_FUN ty unicode
 
+ppLKind :: Bool -> LHsKind DocName -> LaTeX
+ppLKind unicode y = ppKind unicode (unLoc y)
+
+ppKind :: Bool -> HsKind DocName -> LaTeX
+ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
+
 
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
@@ -868,7 +869,7 @@ ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
 ppr_mono_ty _         (HsTyVar name)      _ = ppDocName name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u
 ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
-ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
+ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
 ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsIParamTy n ty)   u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
@@ -876,6 +877,9 @@ ppr_mono_ty _         (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty _         (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
 ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _         (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
+ppr_mono_ty _         (HsWrapTy {})       _ = error "ppr_mono_ty HsWrapTy"
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
   = maybeParen ctxt_prec pREC_OP $
@@ -885,7 +889,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode
   = maybeParen ctxt_prec pREC_FUN $
     ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
   where
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 08e2fe07..9ac4211a 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -558,10 +558,10 @@ miniSynopsis mdl iface unicode qual =
 
 processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
                        -> [Html]
-processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) =
+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
   ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
     TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
-        (TyFamily{}) -> [ppTyFamHeader True False d unicode]
+        (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]
         (TyData{tcdTyPats = ps})
           | Nothing <- ps -> [keyword "data" <+> b]
           | Just _ <- ps  -> [keyword "data" <+> keyword "instance" <+> b]
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index c1f3a89a..44429167 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -35,7 +35,6 @@ import           Text.XHtml hiding     ( name, title, p, quote )
 import GHC
 import Name
 import BasicTypes            ( ipNameName )
-import Outputable            ( ppr, showSDoc, Outputable )
 
 
 -- TODO: use DeclInfo DocName or something
@@ -150,8 +149,8 @@ ppTyName name
 --------------------------------------------------------------------------------
 
 
-ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
-ppTyFamHeader summary associated decl unicode =
+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader summary associated decl unicode qual =
 
   (case tcdFlavour decl of
      TypeFamily
@@ -165,7 +164,7 @@ ppTyFamHeader summary associated decl unicode =
   ppTyClBinderWithVars summary decl <+>
 
   case tcdKind decl of
-    Just kind -> dcolon unicode  <+> ppKind kind
+    Just kind -> dcolon unicode  <+> ppLKind unicode qual kind
     Nothing -> noHtml
 
 
@@ -173,13 +172,13 @@ ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
               TyClDecl DocName -> Bool -> Qualification -> Html
 ppTyFam summary associated links loc mbDoc decl unicode qual
 
-  | summary   = ppTyFamHeader True associated decl unicode
+  | summary   = ppTyFamHeader True associated decl unicode qual
   | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
 
   where
     docname = tcdName decl
 
-    header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode)
+    header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
 
     instancesBit = ppInstances instances docname unicode qual
 
@@ -635,10 +634,6 @@ ppDataHeader summary decl unicode qual
 --------------------------------------------------------------------------------
 
 
-ppKind :: Outputable a => a -> Html
-ppKind k = toHtml $ showSDoc (ppr k)
-
-
 ppBang :: HsBang -> Html
 ppBang HsNoBang = noHtml
 ppBang _        = toHtml "!" -- Unpacked args is an implementation detail,
@@ -684,6 +679,11 @@ ppType       unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
 ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
 ppFunLhType  unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
 
+ppLKind :: Bool -> Qualification-> LHsKind DocName -> Html
+ppLKind unicode qual y = ppKind unicode qual (unLoc y)
+
+ppKind :: Bool -> Qualification-> HsKind DocName -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
 
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
@@ -713,7 +713,7 @@ ppr_mono_ty _         (HsTyVar name)      _ q = ppDocName q name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
 ppr_mono_ty _         (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
 ppr_mono_ty _         (HsKindSig ty kind) u q =
-    parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)
+    parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
 ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsIParamTy n ty)   u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
@@ -725,6 +725,9 @@ ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteT
 #endif
 ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _         (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _         (HsWrapTy {})       _ _ = error "ppr_mono_ty HsWrapTy"
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
   = maybeParen ctxt_prec pREC_OP $
@@ -734,7 +737,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
   = maybeParen ctxt_prec pREC_FUN $
     ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
   where
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index e46a37a4..ea905ed0 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,8 +20,7 @@ module Haddock.Convert where
 import HsSyn
 import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
 import TypeRep
-import Kind ( liftedTypeKind, constraintKind )
-import Coercion ( splitKindFunTys, synTyConResKind )
+import Kind ( liftedTypeKind, constraintKind, splitKindFunTys, synTyConResKind )
 import Name
 import Var
 import Class
@@ -103,14 +102,14 @@ synifyTyCon tc
       -- tyConTyVars doesn't work on fun/prim, but we can make them up:
       (zipWith
          (\fakeTyVar realKind -> noLoc $
-             KindedTyVar (getName fakeTyVar) realKind)
+             KindedTyVar (getName fakeTyVar) (synifyKind realKind) placeHolderKind)
          alphaTyVars --a, b, c... which are unfortunately all kind *
          (fst . splitKindFunTys $ tyConKind tc)
       )
       -- assume primitive types aren't members of data/newtype families:
       Nothing
       -- we have their kind accurately:
-      (Just (tyConKind tc))
+      (Just (synifyKind (tyConKind tc)))
       -- no algebraic constructors:
       []
       -- "deriving" needn't be specified:
@@ -119,13 +118,14 @@ synifyTyCon tc
       case synTyConRhs tc of
         SynFamilyTyCon ->
           TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
-               (Just (synTyConResKind tc))
+               (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind
         _ -> error "synifyTyCon: impossible open type synonym?"
   | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)
       case algTyConRhs tc of
         DataFamilyTyCon ->
           TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
                Nothing --always kind '*'
+               -- placeHolderKind
         _ -> error "synifyTyCon: impossible open data type?"
   | otherwise =
   -- (closed) type, newtype, and data
@@ -164,7 +164,7 @@ synifyTyCon tc
   syn_type = synifyType WithinType (synTyConType tc)
  in if isSynTyCon tc
   then TySynonym name tyvars typats syn_type
-  else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv
+  else TyData alg_nd alg_ctx name tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv
 
 
 -- User beware: it is your responsibility to pass True (use_gadt_syntax)
@@ -238,7 +238,7 @@ synifyTyVars = map synifyTyVar
       name = getName tv
      in if isLiftedTypeKind kind
         then UserTyVar name placeHolderKind
-        else KindedTyVar name kind
+        else KindedTyVar name (synifyKind kind) placeHolderKind
 
 
 --states of what to do with foralls:
@@ -306,6 +306,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
      in noLoc $
            HsForAllTy forallPlicitness sTvs sCtx sTau
 
+synifyKind :: Kind -> LHsKind Name
+synifyKind = synifyType (error "synifyKind")
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
                   ([HsType Name], Name, [HsType Name])
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 546ba62b..88e64cfa 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -211,6 +211,12 @@ renameFnArgsDoc = mapM renameDoc
 renameLType :: LHsType Name -> RnM (LHsType DocName)
 renameLType = mapM renameType
 
+renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
+renameLKind = renameLType
+
+renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind Nothing = return Nothing
+renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just
 
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
@@ -240,17 +246,18 @@ renameType t = case t of
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
 
-  HsOpTy a (L loc op) b -> do
+  HsOpTy a (w, (L loc op)) b -> do
     op' <- rename op
     a'  <- renameLType a
     b'  <- renameLType b
-    return (HsOpTy a' (L loc op') b')
+    return (HsOpTy a' (w, (L loc op')) b')
 
   HsParTy ty -> return . HsParTy =<< renameLType ty
 
   HsKindSig ty k -> do
     ty' <- renameLType ty
-    return (HsKindSig ty' k)
+    k' <- renameLKind k
+    return (HsKindSig ty' k')
 
   HsDocTy ty doc -> do
     ty' <- renameLType ty
@@ -263,7 +270,8 @@ renameType t = case t of
 renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
 renameLTyVarBndr (L loc tv) = do
   name' <- rename (hsTyVarName tv)
-  return $ L loc (replaceTyVarName tv name')
+  tyvar' <- replaceTyVarName tv name' renameLKind
+  return $ L loc tyvar'
 
 
 renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
@@ -311,19 +319,24 @@ renameTyClD d = case d of
     lname' <- renameL lname
     return (ForeignType lname' b)
 
-  TyFamily flav lname ltyvars kind -> do
+--  TyFamily flav lname ltyvars kind tckind -> do
+  TyFamily flav lname ltyvars tckind -> do
     lname'   <- renameL lname
     ltyvars' <- mapM renameLTyVarBndr ltyvars
-    return (TyFamily flav lname' ltyvars' kind)
+--    kind'    <- renameMaybeLKind kind
+    tckind'    <- renameMaybeLKind tckind
+--    return (TyFamily flav lname' ltyvars' kind' tckind)
+    return (TyFamily flav lname' ltyvars' tckind')
 
   TyData x lcontext lname ltyvars typats k cons _ -> do
     lcontext' <- renameLContext lcontext
     lname'    <- renameL lname
     ltyvars'  <- mapM renameLTyVarBndr ltyvars
     typats'   <- mapM (mapM renameLType) typats
+    k'        <- renameMaybeLKind k
     cons'     <- mapM renameLCon cons
     -- I don't think we need the derivings, so we return Nothing
-    return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing)
+    return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing)
 
   TySynonym lname ltyvars typats ltype -> do
     lname'   <- renameL lname