Repository : ssh://[email protected]/haddock On branch : data-kind-syntax Link : http://git.haskell.org/?p=haddock.git;a=commit;h=a92c8663bee3a486c19f0e124898f254e9991425
>--------------------------------------------------------------- commit a92c8663bee3a486c19f0e124898f254e9991425 Author: Trevor Elliott <[email protected]> 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 _______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
