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.hs20
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs27
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs29
4 files changed, 46 insertions, 32 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 7acb3137..2db70c9f 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -64,7 +64,7 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy a b c d) = HsForAllTy a b c (g d)
+ f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e)
f (HsBangTy a b) = HsBangTy a (g b)
f (HsAppTy a b) = HsAppTy (g a) (g b)
f (HsFunTy a b) = HsFunTy (g a) (g b)
@@ -82,7 +82,7 @@ outHsType dflags = out dflags . dropHsDocTy
makeExplicit :: HsType a -> HsType a
-makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c
+makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d
makeExplicit x = x
makeExplicitL :: LHsType a -> LHsType a
@@ -120,21 +120,21 @@ 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
- f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
- f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
+ f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
f (SigD sig) = ppSig dflags sig
f _ = []
ppExport _ _ = []
ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig)
+ppSig dflags (TypeSig names sig _)
= [operator prettyNames ++ " :: " ++ outHsType dflags typ]
where
prettyNames = intercalate ", " $ map (out dflags) names
typ = case unL sig of
- HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
- HsForAllTy Qualified a b c -> HsForAllTy Implicit a b c
+ HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d
+ HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d
x -> x
ppSig _ _ = []
@@ -144,12 +144,12 @@ ppClass :: DynFlags -> TyClDecl Name -> [String]
ppClass dflags x = out dflags x{tcdSigs=[]} :
concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
where
- addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
+ addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
addContext (MinimalSig sig) = MinimalSig sig
addContext _ = error "expected TypeSig"
- f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
- f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
+ f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
+ f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)
context = nlHsTyConApp (tcdName x)
(map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b636ef6b..b717fc01 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -212,7 +212,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t)))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
@@ -249,7 +249,7 @@ ppDocGroup lev doc = sec lev <> braces doc
declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
- SigD (TypeSig lnames _) -> map unLoc lnames
+ SigD (TypeSig lnames _ _) -> map unLoc lnames
SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
ForD (ForeignImport (L _ n) _ _ _) -> [n]
ForD (ForeignExport (L _ n) _ _ _) -> [n]
@@ -293,7 +293,7 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
- SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+ SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
SigD (PatSynSig lname qtvs prov req ty) ->
ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
@@ -393,15 +393,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
- do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+ do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype)
= decltt leader <->
decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
ppLContextNoArrow lctxt unicode) <+> nl $$
do_largs n (darrow unicode) ltype
- do_args n leader (HsForAllTy Qualified a lctxt ltype)
- = do_args n leader (HsForAllTy Implicit a lctxt ltype)
- do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+ do_args n leader (HsForAllTy Qualified e a lctxt ltype)
+ = do_args n leader (HsForAllTy Implicit e a lctxt ltype)
+ do_args n leader (HsForAllTy Implicit _ _ lctxt ltype)
| not (null (unLoc lctxt))
= decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
do_largs n (darrow unicode) ltype
@@ -521,7 +521,7 @@ ppClassDecl instances loc doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
vcat [ ppFunSig loc doc names typ unicode
- | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ | L _ (TypeSig lnames (L _ typ) _) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -895,9 +895,12 @@ ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
= maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
+ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
+ where ctxt' = case extra of
+ Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt
+ Nothing -> ctxt
ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
@@ -937,6 +940,10 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode
ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
= ppr_mono_lty ctxt_prec ty unicode
+ppr_mono_ty _ HsWildcardTy _ = char '_'
+
+ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name
+
ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 455bfcd2..e90be796 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -587,7 +587,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0
(DataDecl{}) -> [keyword "data" <+> b]
(SynDecl{}) -> [keyword "type" <+> b]
(ClassDecl {}) -> [keyword "class" <+> b]
- SigD (TypeSig lnames (L _ _)) ->
+ SigD (TypeSig lnames (L _ _) _) ->
map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
_ -> []
processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index f3e29d9d..25a080d5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -43,11 +43,11 @@ 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 lty fixities splice unicode qual
+ 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 lty fixities splice unicode qual
SigD (PatSynSig lname qtvs prov req ty) ->
ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
@@ -132,7 +132,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocName -> [SubDecl]
- do_args n leader (HsForAllTy _ tvs lctxt ltype)
+ do_args n leader (HsForAllTy _ _ tvs lctxt ltype)
= case unLoc lctxt of
[] -> do_largs n leader' ltype
_ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
@@ -415,7 +415,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
[ ppFunSig summary links loc doc names typ [] splice unicode qual
- | L _ (TypeSig lnames (L _ typ)) <- sigs
+ | L _ (TypeSig lnames (L _ typ) _) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -460,7 +460,7 @@ ppClassDecl summary links instances fixities loc d subdocs
subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
- | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ | L _ (TypeSig lnames (L _ typ) _) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
subfixs = [ f | n <- names
, f@(n',_) <- fixities
@@ -473,12 +473,12 @@ ppClassDecl summary links instances fixities loc d subdocs
minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
- sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
+ sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns]
-> noHtml
-- Minimal complete definition = the only shown method
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
+ [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns]
-> noHtml
-- Minimal complete definition = nothing
@@ -851,8 +851,11 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
- = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt unicode qual
+ = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
<+> ppr_mono_lty pREC_TOP ty unicode qual
+ where ctxt' = case extra of
+ Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt
+ Nothing -> ctxt
-- UnicodeSyntax alternatives
ppr_mono_ty _ (HsTyVar name) True _
@@ -898,6 +901,10 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
= ppr_mono_lty ctxt_prec ty unicode qual
+ppr_mono_ty _ HsWildcardTy _ _ = char '_'
+
+ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name
+
ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 09:42:51 +0000