aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs18
-rw-r--r--haddock-api/src/Haddock/Convert.hs34
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/Utils.hs7
7 files changed, 65 insertions, 26 deletions
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..fab6bf8d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -607,20 +607,26 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
, [subInstDetails iid ats sigs]
)
where
- iid = instanceId origin no orphan ihd
sigs = ppInstanceSigs links splice unicode qual clsiSigs
ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
TypeInst rhs ->
- (ptype, mdoc, [])
+ ( subInstHead iid ptype
+ , mdoc
+ , [subFamInstDetails iid prhs]
+ )
where
- ptype = keyword "type" <+> typ <+> prhs
- prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+ ptype = keyword "type" <+> typ
+ prhs = ptype <+> maybe noHtml
+ (\t -> equals <+> ppType unicode qual t) rhs
DataInst dd ->
- (pdata, mdoc, [])
+ ( subInstHead iid pdata
+ , mdoc
+ , [subFamInstDetails iid pdecl])
where
- pdata = keyword "data" <+> typ <+> pdecl
- pdecl = ppShortDataDecl False True dd unicode qual
+ pdata = keyword "data" <+> typ
+ pdecl = pdata <+> ppShortDataDecl False True dd unicode qual
where
+ iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
@@ -776,7 +782,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 +852,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/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 26aeaff8..41457f72 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,8 @@ module Haddock.Backends.Xhtml.Layout (
subConstructors,
subEquations,
subFields,
- subInstances, subOrphanInstances, subInstHead, subInstDetails,
+ subInstances, subOrphanInstances,
+ subInstHead, subInstDetails, subFamInstDetails,
subMethods,
subMinimal,
@@ -179,7 +180,6 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc
subConstructors :: Qualification -> [SubDecl] -> Html
subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
-
subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
@@ -226,10 +226,18 @@ subInstDetails :: String -- ^ Instance unique id (for anchor generation)
-> [Html] -- ^ Method contents (pretty-printed signatures)
-> Html
subInstDetails iid ats mets =
- section << (subAssociatedTypes ats <+> subMethods mets)
- where
- section = thediv ! collapseSection (instAnchorId iid) False "inst-details"
+ subInstSection iid << (subAssociatedTypes ats <+> subMethods mets)
+
+subFamInstDetails :: String -- ^ Instance unique id (for anchor generation)
+ -> Html -- ^ Type or data family instance
+ -> Html
+subFamInstDetails iid fi =
+ subInstSection iid << thediv ! [theclass "src"] << fi
+subInstSection :: String -- ^ Instance unique id (for anchor generation)
+ -> Html
+ -> Html
+subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details"
instAnchorId :: String -> String
instAnchorId iid = makeAnchorId $ "i:" ++ iid
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index fa6d801c..71a81190 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 )
@@ -34,7 +35,7 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )
-import TysWiredIn ( listTyConName, starKindTyConName )
+import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
import PrelNames ( hasKey, eqTyConKey, ipClassKey
, tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )
import Unique ( getUnique )
@@ -100,8 +101,7 @@ tyThingToLHsDecl t = case t of
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
- (patSynType ps))
+ allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -144,7 +144,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 +154,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 +234,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 +323,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
@@ -357,6 +359,10 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
-- Ditto (see synifySigType)
synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
+synifyPatSynSigType :: PatSyn -> LHsSigType Name
+-- Ditto (see synifySigType)
+synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
+
synifyType :: SynifyTypeState -> Type -> LHsType Name
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
@@ -418,6 +424,22 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
synifyType s (CastTy t _) = synifyType s t
synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
+synifyPatSynType :: PatSyn -> LHsType Name
+synifyPatSynType ps = let
+ (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+ req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]
+ -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
+ -- i.e., an explicit empty context, which is what we need. This is not
+ -- possible by taking theta = [], as that will print no context at all
+ | otherwise = req_theta
+ sForAll [] s = s
+ sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_body = noLoc s }
+ sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
+ , hst_body = noLoc s }
+ sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty
+ in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
+
synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit n) = HsNumTy mempty n
synifyTyLit (StrTyLit s) = HsStrTy mempty s
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" }
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-13 07:56:05 +0000