From cc86b10577d0dcecd5c86102cb601caa474d3d6a Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Wed, 14 Mar 2012 17:35:42 +0000
Subject: Follow changes to tcdKindSig (Trac #5937)

---
 src/Haddock/Backends/Xhtml/Decl.hs |  2 +-
 src/Haddock/Convert.hs             | 17 ++++++++---------
 src/Haddock/Interface/Rename.hs    | 15 +++++++++------
 3 files changed, 18 insertions(+), 16 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 71bcd581..28955c22 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -164,7 +164,7 @@ ppTyFamHeader summary associated decl unicode qual =
   ppTyClBinderWithVars summary decl <+>
 
   case tcdKindSig decl of
-    Just kind -> dcolon unicode  <+> ppLKind unicode qual kind
+    Just (HsBSig kind _) -> dcolon unicode  <+> ppLKind unicode qual kind
     Nothing -> noHtml
 
 
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 480e5728..3dad9a2c 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -104,15 +104,14 @@ synifyTyCon tc
       (zipWith
          (\fakeTyVar realKind -> noLoc $
              KindedTyVar (getName fakeTyVar) 
-                         (HsBSig (synifyKind realKind) placeHolderBndrs) 
-                         placeHolderKind)
+                         (synifyKindSig realKind))
          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 (synifyKind (tyConKind tc)))
+      (Just (synifyKindSig (tyConKind tc)))
       -- no algebraic constructors:
       []
       -- "deriving" needn't be specified:
@@ -121,7 +120,7 @@ synifyTyCon tc
       case synTyConRhs tc of
         SynFamilyTyCon ->
           TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
-               (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind
+               (Just (synifyKindSig (synTyConResKind tc)))
         _ -> error "synifyTyCon: impossible open type synonym?"
   | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)
       case algTyConRhs tc of
@@ -167,7 +166,7 @@ synifyTyCon tc
   syn_type = synifyType WithinType (synTyConType tc)
  in if isSynTyCon tc
   then TySynonym name tyvars typats syn_type placeHolderNames
-  else TyData alg_nd alg_ctx name Nothing tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv
+  else TyData alg_nd alg_ctx name Nothing tyvars typats (fmap synifyKindSig alg_kindSig) alg_cons alg_deriv
 
 
 -- User beware: it is your responsibility to pass True (use_gadt_syntax)
@@ -240,8 +239,8 @@ synifyTyVars = map synifyTyVar
       kind = tyVarKind tv
       name = getName tv
      in if isLiftedTypeKind kind
-        then UserTyVar name placeHolderKind
-        else KindedTyVar name (HsBSig (synifyKind kind) placeHolderBndrs) placeHolderKind
+        then UserTyVar name
+        else KindedTyVar name (synifyKindSig kind)
 
 
 --states of what to do with foralls:
@@ -309,8 +308,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
      in noLoc $
            HsForAllTy forallPlicitness sTvs sCtx sTau
 
-synifyKind :: Kind -> LHsKind Name
-synifyKind = synifyType (error "synifyKind")
+synifyKindSig :: Kind -> HsBndrSig (LHsKind Name)
+synifyKindSig k = HsBSig (synifyType (error "synifyKind") k) placeHolderBndrs
 
 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 a295fe29..6034688e 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -206,9 +206,12 @@ renameLType = mapM renameType
 renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
 renameLKind = renameLType
 
-renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind :: Maybe (HsBndrSig (LHsKind Name)) 
+                 -> RnM (Maybe (HsBndrSig (LHsKind DocName)))
 renameMaybeLKind Nothing = return Nothing
-renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just
+renameMaybeLKind (Just (HsBSig ki fvs))
+  = do { ki' <- renameLKind ki
+       ; return (Just (HsBSig ki' fvs)) }
 
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
@@ -260,13 +263,13 @@ renameType t = case t of
 
 
 renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
-renameLTyVarBndr (L loc (UserTyVar n tck))
+renameLTyVarBndr (L loc (UserTyVar n))
   = do { n' <- rename n
-       ; return (L loc (UserTyVar n' tck)) }
-renameLTyVarBndr (L loc (KindedTyVar n (HsBSig k fvs) tck))
+       ; return (L loc (UserTyVar n')) }
+renameLTyVarBndr (L loc (KindedTyVar n (HsBSig k fvs)))
   = do { n' <- rename n
        ; k' <- renameLKind k
-       ; return (L loc (KindedTyVar n' (HsBSig k' fvs) tck)) }
+       ; return (L loc (KindedTyVar n' (HsBSig k' fvs))) }
 
 renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
 renameLContext (L loc context) = do
-- 
cgit v1.2.3