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/HaddockDB.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs37
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs17
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs61
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs102
8 files changed, 126 insertions, 116 deletions
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs
index 0bdc9057..6c48804a 100644
--- a/haddock-api/src/Haddock/Backends/HaddockDB.hs
+++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs
@@ -104,17 +104,22 @@ ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
hsep (map ppHsAType b)) context)
ppHsType :: HsType -> Doc
-ppHsType (HsForAllType Nothing context htype) =
+ppHsType (HsForAllType _ Nothing context htype) =
hsep [ ppHsContext context, text "=>", ppHsType htype]
-ppHsType (HsForAllType (Just tvs) [] htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
-ppHsType (HsForAllType (Just tvs) context htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." :
+ppHsType (HsForAllType fvf (Just tvs) [] htype) =
+ hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :
+ [ppHsType htype])
+ppHsType (HsForAllType fvf (Just tvs) context htype) =
+ hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :
ppHsContext context : text "=>" : [ppHsType htype])
ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b]
ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
ppHsType t = ppHsBType t
+ppHsForAllSeparator :: ForallVisFlag -> Doc
+ppHsForAllSeparator ForallVis = text "-&gt;"
+ppHsForAllSeparator ForallInvis = text "."
+
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 149f4815..1f98ef9c 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,7 +18,7 @@ module Haddock.Backends.Hoogle (
) where
import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..)
- , PromotionFlag(..) )
+ , PromotionFlag(..), TopLevelFlag(..) )
import InstEnv (ClsInst(..))
import Documentation.Haddock.Markup
import Haddock.GhcUtils
@@ -72,7 +72,7 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy x a e) = HsForAllTy x a (g e)
+ f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e)
f (HsQualTy x a e) = HsQualTy x a (g e)
f (HsBangTy x a b) = HsBangTy x a (g b)
f (HsAppTy x a b) = HsAppTy x (g a) (g b)
@@ -86,8 +86,8 @@ dropHsDocTy = f
f (HsDocTy _ a _) = f $ unL a
f x = x
-outHsType :: (a ~ GhcPass p, OutputableBndrId a)
- => DynFlags -> HsType a -> String
+outHsType :: (OutputableBndrId p)
+ => DynFlags -> HsType (GhcPass p) -> String
outHsType dflags = out dflags . reparenType . dropHsDocTy
@@ -174,7 +174,7 @@ ppClass dflags decl subdocs =
| null $ tcdATs decl = ""
| otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
[ map pprTyFam (tcdATs decl)
- , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
+ , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
]
pprTyFam :: LFamilyDecl GhcRn -> SDoc
@@ -187,15 +187,6 @@ ppClass dflags decl subdocs =
, rbrace
]
- tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn
- tyFamEqnToSyn tfe = SynDecl
- { tcdLName = feqn_tycon tfe
- , tcdTyVars = feqn_pats tfe
- , tcdFixity = feqn_fixity tfe
- , tcdRhs = feqn_rhs tfe
- , tcdSExt = emptyNameSet
- }
-
ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
ppFam dflags decl@(FamilyDecl { fdInfo = info })
= [out dflags decl']
@@ -205,7 +196,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
-- for Hoogle, so pretend it doesn't have any.
ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
_ -> decl
-ppFam _ XFamilyDecl {} = panic "ppFam"
+ppFam _ (XFamilyDecl nec) = noExtCon nec
ppInstance :: DynFlags -> ClsInst -> [String]
ppInstance dflags x =
@@ -254,8 +245,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
[out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y)
- apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)
+ apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
@@ -263,13 +254,13 @@ 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 = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat))
+ resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat))
as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
- in apps (map noLoc (c : as))
+ in apps (map reL (c : as))
tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn
- tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n
- tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k
+ tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
+ tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k
tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor"
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
@@ -279,10 +270,10 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
-ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor"
+ppCtor _ _ _ (XConDecl nec) = noExtCon nec
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]
+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 2e665204..3f5483fe 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -18,7 +18,7 @@ import Data.Maybe
import System.Directory
import System.FilePath
-import HieTypes ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) )
+import HieTypes ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) )
import HieBin ( readHieFile, hie_file_result)
import Data.Map as M
import FastString ( mkFastString )
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 0bd467e1..0247d567 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -9,11 +9,12 @@ import qualified Data.ByteString as BS
import BasicTypes ( IntegralLit(..) )
import DynFlags
-import ErrUtils ( emptyMessages )
+import ErrUtils ( pprLocErrMsg )
import FastString ( mkFastString )
import Lexer ( P(..), ParseResult(..), PState(..), Token(..)
- , mkPStatePure, lexer, mkParserFlags' )
-import Outputable ( showSDoc, panic )
+ , mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError )
+import Bag ( bagToList )
+import Outputable ( showSDoc, panic, text, ($$) )
import SrcLoc
import StringBuffer ( StringBuffer, atEnd )
@@ -31,8 +32,10 @@ parse
-> [T.Token]
parse dflags fpath bs = case unP (go False []) initState of
POk _ toks -> reverse toks
- PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++
- ": " ++ showSDoc dflags errMsg
+ PFailed pst ->
+ let err:_ = bagToList (getErrorMessages pst dflags) in
+ panic $ showSDoc dflags $
+ text "Hyperlinker parse error:" $$ pprLocErrMsg err
where
initState = mkPStatePure pflags buf start
@@ -145,7 +148,7 @@ parse dflags fpath bs = case unP (go False []) initState of
-- | Get the input
getInput :: P (StringBuffer, RealSrcLoc)
-getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)
+getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)
-- | Set the input
setInput :: (StringBuffer, RealSrcLoc) -> P ()
@@ -154,7 +157,7 @@ setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) ()
-- | Orphan instance that adds backtracking to 'P'
instance Alternative P where
- empty = P $ \_ -> PFailed (const emptyMessages) noSrcSpan "Alterative.empty"
+ empty = addFatalError noSrcSpan (text "Alterative.empty")
P x <|> P y = P $ \s -> case x s of { p@POk{} -> p
; _ -> y s }
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index a4dcb77b..404cb9d0 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -88,14 +88,14 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of
-- order to make sure these get hyperlinked properly, we intercept these
-- special sequences of tokens and merge them into just one identifier or
-- operator token.
- [BacktickTok s1, tok @ Token{ tkType = TkIdentifier }, BacktickTok s2]
+ [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2]
| realSrcSpanStart s1 == realSrcSpanStart nodeSpan
, realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan
-> richToken srcs nodeInfo
(Token{ tkValue = "`" <> tkValue tok <> "`"
, tkType = TkOperator
, tkSpan = nodeSpan })
- [OpenParenTok s1, tok @ Token{ tkType = TkOperator }, CloseParenTok s2]
+ [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2]
| realSrcSpanStart s1 == realSrcSpanStart nodeSpan
, realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan
-> richToken srcs nodeInfo
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 2c48e00b..612f3f08 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -129,8 +129,8 @@ recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
go (HLitTy l) = IfaceLitTy l
go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k)
in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
- go (HFunTy a b) = IfaceFunTy a b
- go (HQualTy con b) = IfaceDFunTy con b
+ go (HFunTy a b) = IfaceFunTy VisArg a b
+ go (HQualTy con b) = IfaceFunTy InvisArg con b
go (HCastTy a) = a
go HCoercionTy = IfaceTyVar "<coercion type>"
go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index c62a9311..f2fb1041 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -311,7 +311,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
- ppFunSig Nothing doc [name] (hsSigType typ) unicode
+ ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -355,8 +355,8 @@ ppFamDecl associated doc instances decl unicode =
, equals
, ppType unicode (unLoc rhs)
]
- ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
- ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec
instancesBit = ppDocInstances unicode instances
@@ -365,7 +365,7 @@ ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
-> Bool -- ^ unicode
-> Bool -- ^ is the family associated?
-> LaTeX
-ppFamHeader (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader"
+ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec
ppFamHeader (FamilyDecl { fdLName = L _ name
, fdTyVars = tvs
, fdInfo = info
@@ -388,7 +388,7 @@ ppFamHeader (FamilyDecl { fdLName = L _ name
NoSig _ -> empty
KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind
TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr
- XFamilyResultSig _ -> panic "haddock:ppFamHeader"
+ XFamilyResultSig nec -> noExtCon nec
injAnn = case injectivity of
Nothing -> empty
@@ -449,7 +449,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation
-> Bool -- ^ unicode
-> LaTeX
ppLPatSig doc docnames ty unicode
- = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode
+ = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode
-- | Pretty-print a type, adding documentation to the whole type and its
-- arguments as needed.
@@ -485,9 +485,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
- do_args _n leader (HsForAllTy _ tvs ltype)
+ do_args _n leader (HsForAllTy _ fvf tvs ltype)
= [ ( decltt leader
- , decltt (ppForAllPart unicode tvs)
+ , decltt (ppForAllPart unicode tvs fvf)
<+> ppLType unicode ltype
) ]
do_args n leader (HsQualTy _ lctxt ltype)
@@ -517,6 +517,12 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
gadtOpen = char '{'
+ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX
+ppForAllSeparator unicode fvf =
+ case fvf of
+ ForallVis -> text "\\ " <> arrow unicode
+ ForallInvis -> dot
+
ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
ppTypeSig nms ty unicode =
hsep (punctuate comma $ map ppSymName nms)
@@ -530,7 +536,7 @@ ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc)
tyvarNames :: LHsQTyVars DocNameI -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
+tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -621,7 +627,7 @@ ppClassDecl instances doc subdocs
atTable =
text "\\haddockpremethods{}" <> emph (text "Associated Types") $$
- vcat [ ppFamDecl True (fst doc) [] (FamDecl noExt decl) True
+ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True
| L _ decl <- ats
, let name = unL . fdLName $ decl
doc = lookupAnySubdoc name subdocs
@@ -630,7 +636,7 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}" <> emph (text "Methods") $$
- vcat [ ppFunSig leader doc names (hsSigType typ) unicode
+ vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode
| L _ (ClassOpSig _ is_def lnames typ) <- lsigs
, let doc | is_def = noDocForDecl
| otherwise = lookupAnySubdoc (head names) subdocs
@@ -750,7 +756,7 @@ ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt
where
ppForall
| null tvs || not forall_ = empty
- | otherwise = ppForAllPart unicode tvs
+ | otherwise = ppForAllPart unicode tvs ForallInvis
ppCtxt
| null ctxt = empty
@@ -769,9 +775,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
where
-- Find the name of a constructors in the decl (`getConName` always returns
-- a non-empty list)
- aConName = unLoc (head (getConNames con))
+ aConName = unLoc (head (getConNamesI con))
- occ = map (nameOccName . getName . unLoc) $ getConNames con
+ occ = map (nameOccName . getName . unLoc) $ getConNamesI con
ppOcc = cat (punctuate comma (map ppBinder occ))
ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))
@@ -816,7 +822,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
, ppLType unicode (getGADTConType con)
]
- XConDecl{} -> panic "haddock:ppSideBySideConstr"
+ XConDecl nec -> noExtCon nec
fieldPart = case (con, getConArgs con) of
-- Record style GADTs
@@ -850,12 +856,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
[ l <+> text "\\enspace" <+> r
| (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)
]
- XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
+ XConDecl nec -> noExtCon nec
-- 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 getConNames con of
+ mbDoc = case getConNamesI con of
[] -> panic "empty con_names"
(cn:_) -> lookup (unLoc cn) subdocs >>=
fmap _doc . combineDocumentation . fst
@@ -870,7 +876,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
-ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
+ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec
-- | Pretty-print a bundled pattern synonym
@@ -890,7 +896,7 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode =
| otherwise = hsep [ keyword "pattern"
, ppOcc
, dcolon unicode
- , ppLType unicode (hsSigType typ)
+ , ppLType unicode (hsSigTypeI typ)
]
fieldPart
@@ -900,7 +906,7 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode =
| (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)
]
- patTy = hsSigType typ
+ patTy = hsSigTypeI typ
mDoc = fmap _doc $ combineDocumentation doc
@@ -1037,7 +1043,7 @@ ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind)
-ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
+ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
@@ -1049,8 +1055,13 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX
-ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot
+ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX
+ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv
+ where
+ tvs' = ppTyVars unicode tvs
+ fv = case fvf of
+ ForallVis -> text "\\ " <> arrow unicode
+ ForallInvis -> dot
ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
@@ -1058,8 +1069,8 @@ ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty (HsForAllTy _ tvs ty) unicode
- = sep [ ppForAllPart unicode tvs
+ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode
+ = sep [ ppForAllPart unicode tvs fvf
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 40d630b0..c7ae15ca 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,7 +41,6 @@ import GHC.Exts
import Name
import BooleanFormula
import RdrName ( rdrNameOcc )
-import Outputable ( panic )
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
@@ -65,7 +64,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigWcType lty) fixities splice unicode pkg qual
SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
- (hsSigType lty) fixities splice unicode pkg qual
+ (hsSigTypeI lty) fixities splice unicode pkg qual
ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
@@ -152,8 +151,8 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
- do_args n leader (HsForAllTy _ tvs ltype)
- = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype
+ do_args n leader (HsForAllTy _ fvf tvs ltype)
+ = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype
do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
@@ -219,7 +218,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode pkg qual
- = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual
+ = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -306,8 +305,8 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
, Nothing
, []
)
- ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
- ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec
-- | Print a pseudo family declaration
@@ -332,7 +331,7 @@ ppFamHeader :: Bool -- ^ is a summary
-> Bool -- ^ is an associated type
-> FamilyDecl DocNameI -- ^ family declaration
-> Unicode -> Qualification -> Html
-ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader"
+ppFamHeader _ _ (XFamilyDecl nec) _ _ = noExtCon nec
ppFamHeader summary associated (FamilyDecl { fdInfo = info
, fdResultSig = L _ result
, fdInjectivityAnn = injectivity
@@ -372,7 +371,7 @@ 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
- XFamilyResultSig _ -> panic "haddock:ppResultSig"
+ XFamilyResultSig nec -> noExtCon nec
--------------------------------------------------------------------------------
@@ -497,7 +496,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc noHtml doc names (hsSigType typ)
+ [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ)
[] splice unicode pkg qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -548,31 +547,26 @@ ppClassDecl summary links instances fixities loc d subdocs
, let name = unL . fdLName $ unL at
doc = lookupAnySubdoc name subdocs
subfixs = filter ((== name) . fst) fixities
- defTys = ppDefaultAssocTy name <$> lookupDAT name
+ defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name
]
-- Default associated types
- ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl
- splice unicode pkg qual
- where
- synDecl = SynDecl { tcdSExt = noExt
- , tcdLName = noLoc n
- , tcdTyVars = vs
- , tcdFixity = GHC.Prefix
- , tcdRhs = t }
+ ppDefaultAssocTy n (vs,rhs) = hsep
+ [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals
+ , ppType unicode qual HideEmptyContexts (unLoc rhs)
+ ]
lookupDAT name = Map.lookup (getName name) defaultAssocTys
defaultAssocTys = Map.fromList
- [ (getName name, (vs, typ, doc))
- | L _ (FamEqn { feqn_rhs = typ
- , feqn_tycon = L _ name
- , feqn_pats = vs }) <- atsDefs
- , let doc = noDocForDecl -- TODO: get docs for associated type defaults
+ [ (getName name, (vs, typ))
+ | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ
+ , feqn_tycon = L _ name
+ , feqn_pats = vs }))) <- atsDefs
]
-- Methods
methodBit = subMethods
- [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ)
+ [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ)
subfixs splice unicode pkg qual
<+>
subDefaults (maybeToList defSigs)
@@ -587,7 +581,7 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Default methods
ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")
- d' [n] (hsSigType t) [] splice unicode pkg qual
+ d' [n] (hsSigTypeI t) [] splice unicode pkg qual
lookupDM name = Map.lookup (getOccString name) defaultMethods
defaultMethods = Map.fromList
@@ -777,7 +771,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
pats1 = [ hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
, dcolon unicode
- , ppPatSigType unicode qual (hsSigType typ)
+ , ppPatSigType unicode qual (hsSigTypeI typ)
]
| (SigD _ (PatSynSig _ lnames typ),_) <- pats
]
@@ -823,7 +817,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
[ ppSideBySideConstr subdocs subfixs unicode pkg qual c
| c <- cons
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
- (map unLoc (getConNames (unLoc c)))) fixities
+ (map unLoc (getConNamesI (unLoc c)))) fixities
]
patternBit = subPatterns pkg qual
@@ -888,10 +882,10 @@ ppShortConstrParts summary dataInst con unicode qual
, noHtml
, noHtml
)
- XConDecl {} -> panic "haddock:ppShortConstrParts"
+ XConDecl nec -> noExtCon nec
where
- occ = map (nameOccName . getName . unLoc) $ getConNames con
+ occ = map (nameOccName . getName . unLoc) $ getConNamesI con
ppOcc = hsep (punctuate comma (map (ppBinder summary) occ))
ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ))
@@ -908,10 +902,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
)
where
-- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)
- aConName = unLoc (head (getConNames con))
+ aConName = unLoc (head (getConNamesI con))
fixity = ppFixities fixities qual
- occ = map (nameOccName . getName . unLoc) $ getConNames con
+ occ = map (nameOccName . getName . unLoc) $ getConNamesI con
ppOcc = hsep (punctuate comma (map (ppBinder False) occ))
ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))
@@ -957,7 +951,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
, ppLType unicode qual HideEmptyContexts (getGADTConType con)
, fixity
]
- XConDecl{} -> panic "haddock:ppSideBySideConstr"
+ XConDecl nec -> noExtCon nec
fieldPart = case (con, getConArgs con) of
-- Record style GADTs
@@ -986,11 +980,11 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
ConDeclGADT{} ->
ppSubSigLike unicode qual (unLoc (getGADTConType con))
argDocs subdocs (dcolon unicode) HideEmptyContexts
- XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
+ XConDecl nec -> noExtCon nec
-- 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 = lookup (unLoc $ head $ getConNames con) subdocs >>=
+ mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>=
combineDocumentation . fst
@@ -1005,7 +999,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
where
ppForall
| null tvs || not forall_ = noHtml
- | otherwise = ppForAllPart unicode qual tvs
+ | otherwise = ppForAllPart unicode qual tvs ForallInvis
ppCtxt
| null ctxt = noHtml
@@ -1030,14 +1024,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
-ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
+ppSideBySideField _ _ _ (XConDeclField nec) = noExtCon nec
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField _ names ltype _)
= hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
-ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField"
+ppShortField _ _ _ (XConDeclField nec) = noExtCon nec
-- | Pretty print an expanded pattern (for bundled patterns)
@@ -1060,7 +1054,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
| otherwise = hsep [ keyword "pattern"
, ppOcc
, dcolon unicode
- , ppPatSigType unicode qual (hsSigType typ)
+ , ppPatSigType unicode qual (hsSigTypeI typ)
, fixity
]
@@ -1070,7 +1064,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
argDocs [] (dcolon unicode)
emptyCtxt) ]
- patTy = hsSigType typ
+ patTy = hsSigTypeI typ
emptyCtxt = patSigContext patTy
@@ -1144,7 +1138,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
-ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
+ppHsTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
@@ -1159,16 +1153,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
hasNonEmptyContext :: LHsType name -> Bool
hasNonEmptyContext t =
case unLoc t of
- HsForAllTy _ _ s -> hasNonEmptyContext s
- HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
- HsFunTy _ _ s -> hasNonEmptyContext s
+ HsForAllTy _ _ _ s -> hasNonEmptyContext s
+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsFunTy _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t =
case unLoc t of
- HsForAllTy _ _ s -> isFirstContextEmpty s
- HsQualTy _ cxt _ -> null (unLoc cxt)
- HsFunTy _ _ s -> isFirstContextEmpty s
+ HsForAllTy _ _ _ s -> isFirstContextEmpty s
+ HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsFunTy _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1178,16 +1172,22 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
-ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
-ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
+
+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html
+ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv
+ where
+ tvs' = ppTyVars unicode qual tvs
+ fv = case fvf of
+ ForallVis -> spaceHtml +++ arrow unicode
+ ForallInvis -> dot
ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty (HsForAllTy _ tvs ty) unicode qual emptyCtxts
- = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
+ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts
+ = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty ty unicode qual emptyCtxts
ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
= ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 01:30:02 +0000