From bb994de1ab0c76d1aaf1e39c54158db2526d31f1 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Mon, 14 Mar 2016 23:47:23 -0400 Subject: Changes due to fix for GHC#11648. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/Convert.hs | 9 ++++++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Utils.hs | 7 +++++-- 6 files changed, 17 insertions(+), 11 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index e8baae88..be17cb8b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -117,7 +117,7 @@ decls (group, _, _, _) = concatMap ($ group) ] where typ (GHC.L _ t) = case t of - GHC.DataDecl name _ _ _ -> pure . decl $ name + GHC.DataDecl { tcdLName = name } -> pure . decl $ name GHC.SynDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b7be7ffb..81a23a1b 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -641,7 +641,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = ppOcc = case occ of [one] -> ppBinder one _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) context = unLoc (fromMaybe (noLoc []) (con_cxt con)) -- don't use "con_doc con", in case it's reconstructed from a .hi file, diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2f802aef..b354658d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -776,7 +776,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) + ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) tyVars = tyvarNames ltvs lcontext = fromMaybe (noLoc []) (con_cxt con) context = unLoc lcontext @@ -846,7 +846,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) context = unLoc (fromMaybe (noLoc []) (con_cxt con)) forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fa6d801c..b651c86b 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -26,6 +26,7 @@ import DataCon import FamInstEnv import HsSyn import Name +import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc ) @@ -144,7 +145,7 @@ synifyTyCon _coax tc in HsQTvs { hsq_implicit = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * - } + , hsq_dependent = emptyNameSet } , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: @@ -154,6 +155,7 @@ synifyTyCon _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing } + , tcdDataCusk = False , tcdFVs = placeHolderNamesTc } synifyTyCon _coax tc @@ -233,7 +235,7 @@ synifyTyCon coax tc in case lefts consRaw of [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn - , tcdFVs = placeHolderNamesTc } + , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity @@ -322,7 +324,8 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars Name synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs } + , hsq_explicit = map synifyTyVar ktvs + , hsq_dependent = emptyNameSet } synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0f97ee3b..3054e2f9 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -270,7 +270,7 @@ renameType t = case t of renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -350,7 +350,7 @@ renameTyClD d = case d of lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 325dd710..58a7ef90 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -64,6 +64,7 @@ import Haddock.GhcUtils import GHC import Name +import NameSet ( emptyNameSet ) import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) @@ -201,7 +202,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] c' = ConDeclH98 { con_name = head (con_names c) , con_qvars = Just $ HsQTvs { hsq_implicit = mempty - , hsq_explicit = tvs } + , hsq_explicit = tvs + , hsq_dependent = emptyNameSet } , con_cxt = Just cxt , con_details = details , con_doc = con_doc c @@ -226,7 +228,8 @@ emptyHsQTvs :: LHsQTyVars Name -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] } + , hsq_explicit = [] + , hsq_dependent = error "haddock:emptyHsQTvs" } -------------------------------------------------------------------------------- -- cgit v1.2.3