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/Parser.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs17
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs26
5 files changed, 32 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 27a7d804..75a49036 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -36,6 +36,8 @@ import Data.Version
import System.Directory
import System.FilePath
+import GHC.Core.Multiplicity
+
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
,"-- See Hoogle, http://www.haskell.org/hoogle/"
@@ -76,7 +78,7 @@ dropHsDocTy = f
f (HsBangTy x a b) = HsBangTy x a (g b)
f (HsAppTy x a b) = HsAppTy x (g a) (g b)
f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
- f (HsFunTy x a b) = HsFunTy x (g a) (g b)
+ f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
f (HsListTy x a) = HsListTy x (g a)
f (HsTupleTy x a b) = HsTupleTy x a (map g b)
f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
@@ -236,14 +238,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- AZ:TODO get rid of the concatMap
= concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
where
- f (PrefixCon args) = [typeSig name $ args ++ [resType]]
+ f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
+ f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
[(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
[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 noExtField x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 19c72335..6ced4924 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -265,6 +265,7 @@ classify tok =
ITvbar -> TkGlyph
ITlarrow {} -> TkGlyph
ITrarrow {} -> TkGlyph
+ ITlolly {} -> TkGlyph
ITat -> TkGlyph
ITtilde -> TkGlyph
ITdarrow {} -> TkGlyph
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 17ba00f0..ce5ff11c 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 VisArg a b
- go (HQualTy con b) = IfaceFunTy InvisArg con b
+ go (HFunTy w a b) = IfaceFunTy VisArg w a b
+ go (HQualTy con b) = IfaceFunTy InvisArg many_ty 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 0c323ae5..badb1914 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -41,6 +41,7 @@ import Control.Monad
import Data.Maybe
import Data.List
import Prelude hiding ((<>))
+import GHC.Core.Multiplicity
import Haddock.Doc (combineDocumentation)
@@ -483,13 +484,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
= (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+ do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
= [ (decltt ldr, latex <+> nl)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let latex = ppSideBySideField subdocs unicode field
]
++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
- do_args n leader (HsFunTy _ lt r)
+ do_args n leader (HsFunTy _ _w lt r)
= (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)
: do_largs (n+1) (arrow unicode) r
do_args n leader t
@@ -773,7 +774,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
| hasArgDocs -> header_ <+> ppOcc
| otherwise -> hsep [ header_
, ppOcc
- , hsep (map (ppLParendType unicode) args)
+ , hsep (map ((ppLParendType unicode) . hsScaledThing) args)
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
@@ -783,9 +784,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
InfixCon arg1 arg2
| hasArgDocs -> header_ <+> ppOcc
| otherwise -> hsep [ header_
- , ppLParendType unicode arg1
+ , ppLParendType unicode (hsScaledThing arg1)
, ppOccInfix
- , ppLParendType unicode arg2
+ , ppLParendType unicode (hsScaledThing arg2)
]
ConDeclGADT{}
@@ -804,10 +805,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
(_, RecCon (L _ fields)) -> doRecordFields fields
-- Any GADT or a regular H98 prefix data constructor
- (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args
+ (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
-- An infix H98 data constructor
- (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2]
+ (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
_ -> empty
@@ -1047,7 +1048,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
, ppr_mono_lty ty unicode ]
-ppr_mono_ty (HsFunTy _ ty1 ty2) u
+ppr_mono_ty (HsFunTy _ _ ty1 ty2) u
= sep [ ppr_mono_lty ty1 u
, arrow u <+> ppr_mono_lty ty2 u ]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 5163fb6b..6e210b61 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,6 +41,7 @@ import GHC.Exts
import GHC.Types.Name
import GHC.Data.BooleanFormula
import GHC.Types.Name.Reader ( rdrNameOcc )
+import GHC.Core.Multiplicity
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
@@ -163,14 +164,14 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+ do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
= [ (ldr <+> html, mdoc, subs)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
]
++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
- do_args n leader (HsFunTy _ lt r)
+ do_args n leader (HsFunTy _ _w lt r)
= (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
@@ -836,7 +837,8 @@ ppShortConstrParts summary dataInst con unicode qual
-- Prefix constructor, e.g. 'Just a'
PrefixCon args ->
- ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
+ ( header_ +++
+ hsep (ppOcc : map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
, noHtml
, noHtml
)
@@ -852,9 +854,9 @@ ppShortConstrParts summary dataInst con unicode qual
-- Infix constructor, e.g. 'a :| [a]'
InfixCon arg1 arg2 ->
- ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1
+ ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
, ppOccInfix
- , ppLParendType unicode qual HideEmptyContexts arg2
+ , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
]
, noHtml
, noHtml
@@ -910,7 +912,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
PrefixCon args
| hasArgDocs -> header_ +++ ppOcc <+> fixity
| otherwise -> hsep [ header_ +++ ppOcc
- , hsep (map (ppLParendType unicode qual HideEmptyContexts) args)
+ , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
, fixity
]
@@ -920,9 +922,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
-- Infix constructor, e.g. 'a :| [a]'
InfixCon arg1 arg2
| hasArgDocs -> header_ +++ ppOcc <+> fixity
- | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1
+ | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
, ppOccInfix
- , ppLParendType unicode qual HideEmptyContexts arg2
+ , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
, fixity
]
@@ -957,7 +959,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
doConstrArgsWithDocs args = subFields pkg qual $ case con of
ConDeclH98{} ->
[ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
- | (i, arg) <- zip [0..] args
+ | (i, arg) <- zip [0..] (map hsScaledThing args)
, let mdoc = Map.lookup i argDocs
]
ConDeclGADT{} ->
@@ -1150,14 +1152,14 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
- HsFunTy _ _ s -> hasNonEmptyContext s
+ 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
+ HsFunTy _ _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1197,7 +1199,7 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
| otherwise = ppDocName q Prefix True name
ppr_mono_ty (HsStarTy _ isUni) u _ _ =
toHtml (if u || isUni then "★" else "*")
-ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =
+ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e =
hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
, arrow u <+> ppr_mono_lty ty2 u q e
]
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-23 10:34:33 +0000