aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs74
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs38
3 files changed, 26 insertions, 93 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f1d8ddb2..ee81a83c 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -231,7 +231,7 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
ppCtor dflags dat subdocs con@ConDeclH98 {}
-- AZ:TODO get rid of the concatMap
- = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)
+ = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
@@ -252,15 +252,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
resType = apps $ map (reL . HsTyVar NotPromoted . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
-ppCtor dflags _dat subdocs con@ConDeclGADT {}
+ppCtor dflags _dat subdocs con@(ConDeclGADT { })
= concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
where
- f = [typeSig name (hsib_body $ con_type con)]
+ f = [typeSig name (getGADTConType con)]
typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
-
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d79e0e6c..793e40d8 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -631,7 +631,7 @@ ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
-> LConDecl DocNameI -> LaTeX
ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
leader <->
- case con_details con of
+ case con_args con of
PrefixCon args ->
decltt (hsep ((header_ unicode <+> ppOcc) :
@@ -660,8 +660,8 @@ 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 [] PlaceHolder) (con_qvars con))
- context = unLoc (fromMaybe (noLoc []) (con_cxt con))
+ tyVars = map (getName . hsLTyVarName) (con_ex_tvs con)
+ context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con))
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
@@ -672,7 +672,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =
leader <->
- doGADTCon (hsib_body $ con_type con)
+ doGADTCon (getGADTConType con)
where
doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>
@@ -690,72 +690,6 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =
[] -> panic "empty con_names"
(cn:_) -> lookup (unLoc cn) subdocs >>=
fmap _doc . combineDocumentation . fst
-{- old
-
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
- -> LConDecl DocName -> LaTeX
-ppSideBySideConstr subdocs unicode leader (L loc con) =
- leader <->
- case con_res con of
- ResTyH98 -> case con_details con of
-
- PrefixCon args ->
- decltt (hsep ((header_ unicode <+> ppOcc) :
- map (ppLParendType unicode) args))
- <-> rDoc mbDoc <+> nl
-
- RecCon (L _ fields) ->
- (decltt (header_ unicode <+> ppOcc)
- <-> rDoc mbDoc <+> nl)
- $$
- doRecordFields fields
-
- InfixCon arg1 arg2 ->
- decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
- ppOcc,
- ppLParendType unicode arg2 ])
- <-> rDoc mbDoc <+> nl
-
- ResTyGADT _ resTy -> case con_details con of
- -- prefix & infix could also use hsConDeclArgTys if it seemed to
- -- simplify the code.
- PrefixCon args -> doGADTCon args resTy
- cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
- doRecordFields fields
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
-
- where
- doRecordFields fields =
- vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
-
- doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>
- ppLType unicode (mk_forall $ mk_phi $
- foldr mkFunTy resTy args)
- ) <-> rDoc mbDoc
-
-
- header_ = ppConstrHdr (con_explicit con) tyVars context
- occ = map (nameOccName . getName . unLoc) $ con_names con
- ppOcc = case occ of
- [one] -> ppBinder one
- _ -> cat (punctuate comma (map ppBinder occ))
- ltvs = con_qvars con
- tyVars = tyvarNames (con_qvars con)
- context = unLoc (con_cxt con)
-
- mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)
- | otherwise = ty
- mk_phi ty | null context = ty
- | otherwise = L loc (HsQualTy (con_cxt con) ty)
-
- -- don't use "con_doc con", in case it's reconstructed from a .hi file,
- -- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = case con_names con of
- [] -> panic "empty con_names"
- (cn:_) -> lookup (unLoc cn) subdocs >>=
- fmap _doc . combineDocumentation . fst
- mkFunTy a b = noLoc (HsFunTy a b)
--}
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3b85f96c..bf71fec4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -769,7 +769,7 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
-- incorporated into the declaration
ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html)
ppShortConstrParts summary dataInst con unicode qual = case con of
- ConDeclH98{} -> case con_details con of
+ ConDeclH98{} -> case con_args con of
PrefixCon args ->
(header_ unicode qual +++ hsep (ppOcc
: map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)
@@ -782,17 +782,18 @@ ppShortConstrParts summary dataInst con unicode qual = case con of
ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
noHtml, noHtml)
- ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)
+ ConDeclGADT {} -> (ppOcc <+> dcolon unicode
+ <+> ppLType unicode qual HideEmptyContexts (getGADTConType con)
+ , noHtml, noHtml)
where
- resTy = hsib_body (con_type con)
-
- doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
+ doRecordFields fields = shortSubDecls dataInst $
+ map (ppShortField summary unicode qual) (map unLoc fields)
header_ = ppConstrHdr forall_ tyVars context
- occ = map (nameOccName . getName . unLoc) $ getConNames con
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
- ppOcc = case occ of
+ ppOcc = case occ of
[one] -> ppBinder summary one
_ -> hsep (punctuate comma (map (ppBinder summary) occ))
@@ -800,9 +801,9 @@ ppShortConstrParts summary dataInst con unicode qual = case con of
[one] -> ppBinderInfix summary one
_ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
- ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)
- tyVars = tyvarNames ltvs
- lcontext = fromMaybe (noLoc []) (con_cxt con)
+ -- Used for H98 syntax only
+ tyVars = map (getName . hsLTyVarName) (con_ex_tvs con)
+ lcontext = fromMaybe (noLoc []) (con_mb_cxt con)
context = unLoc lcontext
forall_ = False
@@ -827,7 +828,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
= (decl, mbDoc, fieldPart)
where
decl = case con of
- ConDeclH98{} -> case con_details con of
+ ConDeclH98{} -> case con_args con of
PrefixCon args ->
hsep ((header_ +++ ppOcc)
: map (ppLParendType unicode qual HideEmptyContexts) args)
@@ -841,11 +842,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ppLParendType unicode qual HideEmptyContexts arg2]
<+> fixity
- ConDeclGADT{} -> doGADTCon resTy
-
- resTy = hsib_body (con_type con)
+ ConDeclGADT{} -> doGADTCon (getGADTConType con)
- fieldPart = case getConDetails con of
+ fieldPart = case getConArgs con of
RecCon (L _ fields) -> [doRecordFields fields]
_ -> []
@@ -860,9 +859,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
fixity = ppFixities fixities qual
header_ = ppConstrHdr forall_ tyVars context unicode qual
- occ = map (nameOccName . getName . unLoc) $ getConNames con
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
- ppOcc = case occ of
+ ppOcc = case occ of
[one] -> ppBinder False one
_ -> hsep (punctuate comma (map (ppBinder False) occ))
@@ -870,8 +869,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
[one] -> ppBinderInfix False one
_ -> hsep (punctuate comma (map (ppBinderInfix False) occ))
- tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))
- context = unLoc (fromMaybe (noLoc []) (con_cxt con))
+ -- Used for H98 syntax only
+ tyVars = map (getName . hsLTyVarName) (con_ex_tvs con)
+ context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con))
forall_ = False
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:34:45 +0000