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.hs13
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs26
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs32
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs48
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs9
9 files changed, 105 insertions, 52 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9a15c7b3..86a73c33 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Hoogle
@@ -15,7 +16,7 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-import BasicTypes (OverlapFlag(..), OverlapMode(..))
+import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
import InstEnv (ClsInst(..))
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
@@ -84,7 +85,8 @@ dropHsDocTy = f
f (HsDocTy a _) = f $ unL a
f x = x
-outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
+outHsType :: (OutputableBndrId a)
+ => DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
@@ -180,6 +182,7 @@ ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMet
tyFamEqnToSyn tfe = SynDecl
{ tcdLName = tfe_tycon tfe
, tcdTyVars = tfe_pats tfe
+ , tcdFixity = tfe_fixity tfe
, tcdRhs = tfe_rhs tfe
, tcdFVs = emptyNameSet
}
@@ -194,7 +197,7 @@ ppInstance dflags x =
-- safety information to a state where the Outputable instance
-- produces no output which means no overlap and unsafe (or [safe]
-- is generated).
- cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty
+ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText
, isSafeOverlap = False } }
ppSynonym :: DynFlags -> TyClDecl Name -> [String]
@@ -202,7 +205,7 @@ ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
where
@@ -242,7 +245,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- resType = apps $ map (reL . HsTyVar . reL) $
+ resType = apps $ map (reL . HsTyVar NotPromoted . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@ConDeclGADT {}
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index be17cb8b..b97f0ead 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -72,7 +72,7 @@ types =
everything (<|>) ty
where
ty term = case cast term of
- (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+ (Just (GHC.L sspan (GHC.HsTyVar _ name))) ->
pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
@@ -118,7 +118,7 @@ decls (group, _, _, _) = concatMap ($ group)
where
typ (GHC.L _ t) = case t of
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
- GHC.SynDecl 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
fun term = case cast term of
@@ -152,11 +152,11 @@ imports src@(_, imps, _, _) =
everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just (GHC.IEVar v)) -> pure $ var v
- (Just (GHC.IEThingAbs t)) -> pure $ typ t
- (Just (GHC.IEThingAll t)) -> pure $ typ t
+ (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith t _ vs _fls)) ->
- [typ t] ++ map var vs
+ [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) 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/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index e206413e..e4345602 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -31,12 +31,20 @@ chunk str@(c:_)
chunk str
| "--" `isPrefixOf` str = chunk' $ spanToNewline str
| "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
- | otherwise = case lex str of
+ | otherwise = case lex' str of
(tok:_) -> chunk' tok
[] -> [str]
where
chunk' (c, rest) = c:(chunk rest)
+-- | A bit better lexer then the default, i.e. handles DataKinds quotes
+lex' :: ReadS String
+lex' ('\'' : '\'' : rest) = [("''", rest)]
+lex' str@('\'' : '\\' : _ : '\'' : _) = lex str
+lex' str@('\'' : _ : '\'' : _) = lex str
+lex' ('\'' : rest) = [("'", rest)]
+lex' str = lex str
+
-- | Split input to "first line" string and the rest of it.
--
-- Ideally, this should be done simply with @'break' (== '\n')@. However,
@@ -124,6 +132,8 @@ classify str
| "--" `isPrefixOf` str = TkComment
| "{-#" `isPrefixOf` str = TkPragma
| "{-" `isPrefixOf` str = TkComment
+classify "''" = TkSpecial
+classify "'" = TkSpecial
classify str@(c:_)
| isSpace c = TkSpace
| isDigit c = TkNumber
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index 5f4dbc8c..b27ec4d8 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -12,16 +12,19 @@ data Token = Token
, tkValue :: String
, tkSpan :: Span
}
+ deriving (Show)
data Position = Position
{ posRow :: !Int
, posCol :: !Int
}
+ deriving (Show)
data Span = Span
{ spStart :: Position
, spEnd :: Position
}
+ deriving (Show)
data TokenType
= TkIdentifier
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 81a23a1b..53cfccff 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -251,7 +251,7 @@ declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
SigD (TypeSig lnames _ ) -> map unLoc lnames
- SigD (PatSynSig lname _) -> [unLoc lname]
+ SigD (PatSynSig lnames _) -> map unLoc lnames
ForD (ForeignImport (L _ n) _ _ _) -> [n]
ForD (ForeignExport (L _ n) _ _ _) -> [n]
_ -> error "declaration not supported by declNames"
@@ -296,10 +296,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
(hsSigWcType t) unicode
- SigD (PatSynSig lname ty) ->
- ppLPatSig loc (doc, fnArgsDoc) lname ty unicode
+ SigD (PatSynSig lnames ty) ->
+ ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
+ DerivD _ -> empty
_ -> error "declaration not supported by ppDecl"
where
unicode = False
@@ -354,14 +355,14 @@ ppFunSig loc doc docnames (L _ typ) unicode =
where
names = map getName docnames
-ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
+ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]
-> LHsSigType DocName
-> Bool -> LaTeX
-ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode
+ppLPatSig _loc (doc, _argDocs) docnames ty unicode
= declWithDoc pref1 (documentationToLaTeX doc)
where
pref1 = hsep [ keyword "pattern"
- , ppDocBinder name
+ , hsep $ punctuate comma $ map ppDocBinder docnames
, dcolon unicode
, ppLType unicode (hsSigType ty)
]
@@ -884,6 +885,10 @@ tupleParens HsUnboxedTuple = ubxParenList
tupleParens _ = parenList
+sumParens :: [LaTeX] -> LaTeX
+sumParens = ubxparens . hsep . punctuate (text " | ")
+
+
-------------------------------------------------------------------------------
-- * Rendering of HsType
--
@@ -944,17 +949,20 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
, ppr_mono_lty pREC_TOP ty unicode ]
ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys)
ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 0958c2cd..7b5f9017 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -43,10 +43,11 @@ import System.Directory
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set hiding ( Set )
+import Data.Function
import Data.Ord ( comparing )
import DynFlags (Language(..))
-import GHC hiding ( NoLink, moduleInfo )
+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import Name
import Module
@@ -263,13 +264,20 @@ ppHtmlContents dflags odir doctitle _maybe_package
themes mathjax_url maybe_index_url
maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
let tree = mkModuleTree dflags showPkgs
- [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- ifaces
+ , not (instIsSig iface)]
+ sig_tree = mkModuleTree dflags showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- ifaces
+ , instIsSig iface]
html =
headHtml doctitle Nothing themes mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
ppPrologue qual doctitle prologue,
+ ppSignatureTree qual sig_tree,
ppModuleTree qual tree
]
createDirectoryIfMissing True odir
@@ -282,7 +290,13 @@ ppPrologue qual title (Just doc) =
divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
+ppSignatureTree :: Qualification -> [ModuleTree] -> Html
+ppSignatureTree qual ts =
+ divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)
+
+
ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree _ [] = mempty
ppModuleTree qual ts =
divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
@@ -469,13 +483,20 @@ ppHtmlModule odir doctitle themes
mdl = ifaceMod iface
aliases = ifaceModuleAliases iface
mdl_str = moduleString mdl
+ mdl_str_annot = mdl_str ++ if ifaceIsSig iface
+ then " (signature)"
+ else ""
+ mdl_str_linked = mdl_str +++
+ " (signature" +++
+ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
+ ")"
real_qual = makeModuleQual qual aliases mdl
html =
- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+ headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
- divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
+ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
]
@@ -483,6 +504,9 @@ ppHtmlModule odir doctitle themes
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
+signatureDocURL :: String
+signatureDocURL = "https://wiki.haskell.org/Module_signature"
+
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
-> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index fab6bf8d..2aec5272 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -34,7 +34,7 @@ import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
-import GHC
+import GHC hiding (LexicalFixity(..))
import GHC.Exts
import Name
import BooleanFormula
@@ -44,17 +44,18 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigWcType lty) fixities splice unicode qual
- SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname
+ SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
ty fixities splice unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
- InstD _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ InstD _ -> noHtml
+ DerivD _ -> noHtml
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
@@ -74,22 +75,20 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
pp_typ = ppLType unicode qual typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- Located DocName -> LHsSigType DocName ->
+ [Located DocName] -> LHsSigType DocName ->
[(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual
| summary = pref1
- | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
+ | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)
+++ docSection Nothing qual doc
where
pref1 = hsep [ keyword "pattern"
- , ppBinder summary occname
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
, dcolon unicode
, ppLType unicode qual (hsSigType typ)
]
- occname = nameOccName . getName $ name
-
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
Splice -> Unicode -> Qualification -> Html
@@ -645,10 +644,8 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstanceSigs links splice unicode qual sigs = do
TypeSig lnames typ <- sigs
let names = map unLoc lnames
- L loc rtyp = get_type typ
+ L loc rtyp = hsSigWcType 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
@@ -916,6 +913,9 @@ tupleParens HsUnboxedTuple = ubxParenList
tupleParens _ = parenList
+sumParens :: [Html] -> Html
+sumParens = ubxSumList
+
--------------------------------------------------------------------------------
-- * Rendering of HsType
--------------------------------------------------------------------------------
@@ -984,19 +984,20 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar (L _ name)) True _
+ppr_mono_ty _ (HsTyVar _ (L _ name)) True _
| getOccString (getName name) == "*" = toHtml "★"
| getOccString (getName name) == "(->)" = toHtml "(→)"
ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name
+ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
+ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys)
ppr_mono_ty _ (HsKindSig ty kind) u q =
parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =
+ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q =
maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
@@ -1004,7 +1005,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
-- placeholder in the signature, which is followed by the field
-- declarations.
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys
ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 5492178b..a84a55e8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -26,7 +26,7 @@ import Text.XHtml hiding ( name, title, p, quote )
import qualified Data.Map as M
import qualified Data.List as List
-import GHC
+import GHC hiding (LexicalFixity(..))
import Name
import RdrName
import FastString (unpackFS)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 1d49807d..a8b4a4ec 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -20,7 +20,7 @@ module Haddock.Backends.Xhtml.Utils (
(<+>), (<=>), char,
keyword, punctuate,
- braces, brackets, pabrackets, parens, parenList, ubxParenList,
+ braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
hsep, vcat,
@@ -75,8 +75,7 @@ spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
case span_ of
RealSrcSpan span__ ->
show $ srcSpanStartLine span__
- UnhelpfulSpan _ ->
- error "spliceURL UnhelpfulSpan"
+ UnhelpfulSpan _ -> ""
run "" = ""
run ('%':'M':rest) = mdl ++ run rest
@@ -178,6 +177,10 @@ ubxParenList :: [Html] -> Html
ubxParenList = ubxparens . hsep . punctuate comma
+ubxSumList :: [Html] -> Html
+ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
+
+
ubxparens :: Html -> Html
ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:31:08 +0000