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.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs24
3 files changed, 33 insertions, 25 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index a8882fe2..1adcddfc 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
- f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
- f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+ f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
f (SigD sig) = ppSig dflags sig ++ ppFixities
f _ = []
@@ -157,10 +157,10 @@ ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods
where
- ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl
- ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
+ ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
+ ppSig' = flip (ppSigWithDoc dflags) subdocs
- add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
+ add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
ppTyFams
| null $ tcdATs decl = ""
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 5eca973e..060534bf 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
module Haddock.Backends.Hyperlinker.Ast (enrich) where
@@ -10,6 +11,7 @@ import Haddock.Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
+import qualified FieldLabel as GHC
import Control.Applicative
import Data.Data
@@ -56,8 +58,8 @@ variables =
where
var term = case cast term of
(Just (GHC.L sspan (GHC.HsVar name))) ->
- pure (sspan, RtkVar name)
- (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) ->
+ pure (sspan, RtkVar (GHC.unLoc name))
+ (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
pure (sspan, RtkVar name)
_ -> empty
rec term = case cast term of
@@ -72,7 +74,7 @@ types =
where
ty term = case cast term of
(Just (GHC.L sspan (GHC.HsTyVar name))) ->
- pure (sspan, RtkType name)
+ pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
-- | Obtain details map for identifier bindings.
@@ -85,12 +87,12 @@ binds =
everything (<|>) (fun `combine` pat `combine` tvar)
where
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
pure (sspan, RtkBind name)
_ -> empty
pat term = case cast term of
(Just (GHC.L sspan (GHC.VarPat name))) ->
- pure (sspan, RtkBind name)
+ pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
[(sspan, RtkVar name)] ++ everything (<|>) rec recs
(Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
@@ -102,7 +104,7 @@ binds =
_ -> empty
tvar term = case cast term of
(Just (GHC.L sspan (GHC.UserTyVar name))) ->
- pure (sspan, RtkBind name)
+ pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -121,7 +123,7 @@ decls (group, _, _, _) = concatMap ($ group)
GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
@@ -134,9 +136,10 @@ decls (group, _, _, _) = concatMap ($ group)
pure . tyref $ GHC.tfe_tycon eqn
_ -> empty
fld term = case cast term of
- Just field -> map decl $ GHC.cd_fld_names field
+ Just (field :: GHC.ConDeclField GHC.Name)
+ -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
- sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names
+ sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
sig _ = []
decl (GHC.L sspan name) = (sspan, RtkDecl name)
tyref (GHC.L sspan name) = (sspan, RtkType name)
@@ -153,7 +156,8 @@ imports src@(_, imps, _, _) =
(Just (GHC.IEVar v)) -> pure $ var v
(Just (GHC.IEThingAbs t)) -> pure $ typ t
(Just (GHC.IEThingAll t)) -> pure $ typ t
- (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
+ (Just (GHC.IEThingWith t _ vs _fls)) ->
+ [typ t] ++ map var vs
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 124debfb..ae1905bf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -270,24 +270,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
) <+>
ppFamDeclBinderWithVars summary d <+>
-
- (case result of
- NoSig -> noHtml
- KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
- TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
- ) <+>
+ ppResultSig result unicode qual <+>
(case injectivity of
Nothing -> noHtml
Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
)
+ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+ NoSig -> noHtml
+ KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+
ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
-> Html
ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
ppFamilyInfo True pfdInfo <+>
ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
- ppFamilyKind unicode qual pfdKindSig
+ ppResultSig (unLoc pfdKindSig) unicode qual
ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
@@ -530,7 +531,7 @@ ppClassDecl summary links instances fixities loc d subdocs
minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
- sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
+ sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
-> noHtml
-- Minimal complete definition = the only shown method
@@ -612,9 +613,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-> [Sig DocName]
-> [Html]
ppInstanceSigs links splice unicode qual sigs = do
- TypeSig lnames (L loc typ) _ <- sigs
+ TypeSig lnames typ <- sigs
let names = map unLoc lnames
- return $ ppSimpleSig links splice unicode qual loc names typ
+ L loc rtyp = get_type typ
+ return $ ppSimpleSig links splice unicode qual loc names rtyp
+ where
+ get_type = hswc_body . hsib_body
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 13:47:53 +0000