aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/Hoogle.hs19
-rw-r--r--src/Haddock/Backends/LaTeX.hs23
-rw-r--r--src/Haddock/Backends/Xhtml.hs12
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs62
4 files changed, 59 insertions, 57 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 28d35aca..64905a37 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -112,9 +112,8 @@ operator x = x
ppExport :: DynFlags -> ExportItem Name -> [String]
ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
- f (TyClD d@TyDecl{})
- | isDataDecl d = ppData dflags d subdocs
- | otherwise = ppSynonym dflags d
+ f (TyClD d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d
f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
@@ -145,8 +144,8 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
- context = nlHsTyConApp (unL $ tcdLName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x)))
+ context = nlHsTyConApp (tcdName x)
+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
ppInstance :: DynFlags -> ClsInst -> [String]
@@ -157,9 +156,9 @@ ppSynonym :: DynFlags -> TyClDecl Name -> [String]
ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
- = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} :
- concatMap (ppCtor dflags decl subdocs . unL) (td_cons defn)
+ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
+ concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
where
-- GHC gives out "data Bar =", we want to delete the equals
@@ -167,7 +166,7 @@ ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
showData d = unwords $ map f $ if last xs == "=" then init xs else xs
where
xs = words $ out dflags d
- nam = out dflags $ tcdLName d
+ nam = out dflags $ tyClDeclLName d
f w = if w == nam then operator nam else w
ppData _ _ _ = panic "ppData"
@@ -196,7 +195,7 @@ ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
resType = case con_res con of
ResTyH98 -> apps $ map (reL . HsTyVar) $
- unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat]
+ (tcdName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tyClDeclTyVars dat]
ResTyGADT x -> x
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index bf1e6ac3..5d0fabe9 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import GHC
import OccName
import Name ( nameOccName )
import RdrName ( rdrNameOcc )
-import FastString ( unpackFS, unpackLitString )
+import FastString ( unpackFS, unpackLitString, zString )
import qualified Data.Map as Map
import System.Directory
@@ -168,6 +168,7 @@ string_txt :: TextDetails -> String -> String
string_txt (Chr c) s = c:s
string_txt (Str s1) s2 = s1 ++ s2
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
+string_txt (ZStr s1) s2 = zString s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
@@ -242,7 +243,7 @@ ppDocGroup lev doc = sec lev <> braces doc
declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
- TyClD d -> [unLoc $ tcdLName d]
+ TyClD d -> [tcdName d]
SigD (TypeSig lnames _) -> map unLoc lnames
_ -> error "declaration not supported by declNames"
@@ -274,10 +275,10 @@ ppDecl :: LHsDecl DocName
-> LaTeX
ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
- TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode
- TyClD d@(TyDecl{ tcdTyDefn = defn })
- | isHsDataDefn defn -> ppDataDecl instances subdocs loc doc d unicode
- | otherwise -> ppTySyn loc (doc, fnArgsDoc) d unicode
+ TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
+ TyClD d@(DataDecl {})
+ -> ppDataDecl instances subdocs loc doc d unicode
+ TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
@@ -310,8 +311,8 @@ ppFor _ _ _ _ =
-- we skip type patterns for now
ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
-ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
+ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype }) unicode
= ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
@@ -548,7 +549,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
$$ instancesBit
where
- cons = td_cons (tcdTyDefn dataDecl)
+ cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
body = catMaybes [constrBit, documentationToLaTeX doc]
@@ -693,8 +694,8 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
-ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
- , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode
+ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
+ , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
= -- newtype or data
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index c68b7cbc..3251477a 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -556,10 +556,10 @@ processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]
- (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
- (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
- (ClassDecl {}) -> [keyword "class" <+> b]
+ (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
+ (DataDecl{}) -> [keyword "data" <+> b]
+ (SynDecl{}) -> [keyword "type" <+> b]
+ (ClassDecl {}) -> [keyword "class" <+> b]
_ -> []
SigD (TypeSig lnames (L _ _)) ->
map (ppNameMini mdl . nameOccName . getName . unLoc) lnames
@@ -578,8 +578,8 @@ ppNameMini mdl nm =
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
ppTyClBinderWithVarsMini mdl decl =
- let n = unLoc $ tcdLName decl
- ns = tyvarNames $ tcdTyVars decl
+ let n = tcdName decl
+ ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 59be34f7..db39ccca 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,10 +39,9 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual
- TyClD d@(TyDecl{ tcdTyDefn = defn })
- | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
@@ -115,8 +114,8 @@ ppFor _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
-> Qualification -> Html
-ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdTyDefn = TySynonym { td_synRhs = ltype } })
+ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype })
unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode qual
@@ -145,10 +144,10 @@ ppTyName name
--------------------------------------------------------------------------------
-ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyFamHeader summary associated decl unicode qual =
-
- (case tcdFlavour decl of
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader summary associated d@(FamilyDecl { fdFlavour = flav
+ , fdKindSig = mkind }) unicode qual =
+ (case flav of
TypeFamily
| associated -> keyword "type"
| otherwise -> keyword "type family"
@@ -157,22 +156,22 @@ ppTyFamHeader summary associated decl unicode qual =
| otherwise -> keyword "data family"
) <+>
- ppTyClBinderWithVars summary decl <+>
+ ppFamDeclBinderWithVars summary d <+>
- case tcdKindSig decl of
+ case mkind of
Just kind -> dcolon unicode <+> ppLKind unicode qual kind
Nothing -> noHtml
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
- TyClDecl DocName -> Bool -> Qualification -> Html
+ FamilyDecl DocName -> Bool -> Qualification -> Html
ppTyFam summary associated links loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection qual doc +++ instancesBit
where
- docname = tcdName decl
+ docname = unLoc $ fdLName decl
header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
@@ -187,23 +186,25 @@ ppTyFam summary associated links loc doc decl unicode qual
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
-> Qualification -> Html
ppAssocType summ links doc (L loc decl) unicode qual =
- case decl of
- TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
- _ -> error "declaration type not supported by ppAssocType"
+ ppTyFam summ True links loc (fst doc) decl unicode qual
--------------------------------------------------------------------------------
-- * TyClDecl helpers
--------------------------------------------------------------------------------
+-- | Print a type family and its variables
+ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
+ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
+ ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
--- | Print a type family / newtype / data / class binder and its variables
-ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html
-ppTyClBinderWithVars summ decl =
- ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
+-- | Print a newtype / data binder and its variables
+ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppDataBinderWithVars summ decl =
+ ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
--------------------------------------------------------------------------------
@@ -303,7 +304,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
+++ shortSubDecls
(
[ ppAssocType summary links doc at unicode qual | at <- ats
- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-- ToDo: add associated type defaults
@@ -336,14 +337,14 @@ ppClassDecl summary links instances loc d subdocs
| null lsigs = topDeclElem links loc [nm] (hdr unicode qual)
| otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where")
- nm = unLoc $ tcdLName decl
+ nm = tcdName decl
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-- ToDo: add assocatied typ defaults
atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual
| at <- ats
- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]
methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual
| L _ (TypeSig lnames (L _ typ)) <- lsigs
@@ -401,7 +402,7 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
- cons = td_cons (tcdTyDefn dataDecl)
+ cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
@@ -415,8 +416,8 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
| otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
where
- docname = unLoc . tcdLName $ dataDecl
- cons = td_cons (tcdTyDefn dataDecl)
+ docname = tcdName dataDecl
+ cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
@@ -570,14 +571,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } })
+ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd
+ , dd_ctxt = ctxt } })
unicode qual
= -- newtype or data
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
ppLContext ctxt unicode qual <+>
-- T a b c ..., or a :+: b
- ppTyClBinderWithVars summary decl
+ ppDataBinderWithVars summary decl
ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:22:10 +0000