[commit: haddock] data-kind-syntax: Handle data kind syntax changes (a92c866)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haddock

On branch  : data-kind-syntax
Link       : http://git.haskell.org/?p=haddock.git;a=commit;h=a92c8663bee3a486c19f0e124898f254e9991425

>---------------------------------------------------------------

commit a92c8663bee3a486c19f0e124898f254e9991425
Author: Trevor Elliott <trevor at galois.com>
Date:   Sun Sep 8 21:43:57 2013 -0700

    Handle data kind syntax changes


>---------------------------------------------------------------

a92c8663bee3a486c19f0e124898f254e9991425
 src/Haddock/Convert.hs          |   14 ++++++++++++--
 src/Haddock/Interface/Rename.hs |   30 +++++++++++++++++++++++++++---
 2 files changed, 39 insertions(+), 5 deletions(-)

diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 04acbc9..2e13f2c 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -114,6 +114,13 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
   | otherwise
   = error "synifyAxiom: closed/open family confusion"
 
+tryPromote :: TyCon -> Bool
+tryPromote tc =
+  case promotableTyConInfo tc of
+    -- False when promotion was explicitly disabled, true otherwise.
+    NeverPromote -> False
+    _            -> True
+
 synifyTyCon :: TyCon -> TyClDecl Name
 synifyTyCon tc
   | isFunTyCon tc || isPrimTyCon tc 
@@ -135,7 +142,8 @@ synifyTyCon tc
                                       , dd_kindSig = Just (synifyKindSig (tyConKind tc))
                                                -- we have their kind accurately:
                                       , dd_cons = []  -- No constructors
-                                      , dd_derivs = Nothing }
+                                      , dd_derivs = Nothing
+                                      , dd_try_promote = tryPromote tc }
            , tcdFVs = placeHolderNames }
 
   | isSynFamilyTyCon tc 
@@ -200,7 +208,9 @@ synifyTyCon tc
                     , dd_cType   = Nothing
                     , dd_kindSig = fmap synifyKindSig kindSig
                     , dd_cons    = cons 
-                    , dd_derivs  = alg_deriv }
+                    , dd_derivs  = alg_deriv
+                    , dd_try_promote = tryPromote tc
+                    }
  in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
              , tcdFVs = placeHolderNames }
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index a6f4852..5f684fe 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -369,6 +369,13 @@ renameTyClD d = case d of
                       , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
                       , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
 
+  KindDecl { tcdLName = lname, tcdKVars = lkvars, tcdTypeCons = lcons } -> do
+    lname'  <- renameL lname
+    lkvars' <- mapM renameL lkvars
+    lcons'  <- mapM (renameLThing renameTyConDecl) lcons
+    return KindDecl { tcdLName = lname', tcdKVars = lkvars', tcdTypeCons = lcons'
+                    , tcdFvs = placeHolderNames }
+
   where
     renameLFunDep (L loc (xs, ys)) = do
       xs' <- mapM rename xs
@@ -377,6 +384,22 @@ renameTyClD d = case d of
 
     renameLSig (L loc sig) = return . L loc =<< renameSig sig
 
+renameTyConDecl :: TyConDecl Name -> RnM (TyConDecl DocName)
+renameTyConDecl (TyConDecl { tycon_name = lname, tycon_details = details, tycon_doc = doc }) = do
+  lname'   <- renameL lname
+  details' <- renameDetails details
+  doc'     <- mapM renameLDocHsSyn doc
+  return TyConDecl { tycon_name = lname', tycon_details = details'
+                   , tycon_doc = doc' }
+
+  where
+  renameDetails (RecCon ()) = return (RecCon ())
+  renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+  renameDetails (InfixCon a b) = do
+    a' <- renameLType a
+    b' <- renameLType b
+    return (InfixCon a' b')
+
 renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
 renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
                              , fdTyVars = ltyvars, fdKindSig = tckind }) = do
@@ -396,13 +419,15 @@ renameFamilyInfo (ClosedTypeFamily eqns)
 
 renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
 renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
-                           , dd_kindSig = k, dd_cons = cons }) = do
+                           , dd_kindSig = k, dd_cons = cons
+                           , dd_try_promote = try_prom }) = do
     lcontext' <- renameLContext lcontext
     k'        <- renameMaybeLKind k
     cons'     <- mapM (mapM renameCon) cons
     -- I don't think we need the derivings, so we return Nothing
     return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
-                       , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
+                       , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing
+                       , dd_try_promote = try_prom })
 
 renameCon :: ConDecl Name -> RnM (ConDecl DocName)
 renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
@@ -427,7 +452,6 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
     renameResType (ResTyH98) = return ResTyH98
     renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
 
-
 renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
 renameConDeclFieldField (ConDeclField name t doc) = do
   name' <- renameL name