aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs16
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs24
-rw-r--r--haddock-api/src/Haddock/Convert.hs8
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs16
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs7
9 files changed, 50 insertions, 34 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f7e1c77b..1a0cccf7 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -281,7 +281,7 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
name = out dflags $ map unL names
con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
theta_ty = case mcxt of
- Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+ Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 52d73265..2def35ae 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -274,6 +274,7 @@ classify tok =
ITprefixminus -> TkGlyph
ITbang -> TkGlyph
ITdot -> TkOperator
+ ITproj {} -> TkOperator
ITstar {} -> TkOperator
ITtypeApp -> TkGlyph
ITpercent -> TkGlyph
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df1f94e6..e2e16947 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,7 +25,7 @@ import GHC.Utils.Ppr hiding (Doc, quote)
import qualified GHC.Utils.Ppr as Pretty
import GHC.Types.Basic ( PromotionFlag(..) )
-import GHC
+import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
import GHC.Types.Name ( nameOccName )
import GHC.Types.Name.Reader ( rdrNameOcc )
@@ -597,12 +597,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
-> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
+ <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty)
<+> ppAppDocNameNames summ n (tyvarNames tvs)
<+> ppFds fds unicode
@@ -806,7 +806,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
, con_ex_tvs = tyVars
, con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode
in case det of
-- Prefix constructor, e.g. 'Just a'
@@ -980,9 +980,11 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX
-ppLContext = ppContext . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
+ppLContext Nothing _ = empty
+ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode
+ppLContextNoArrow Nothing _ = empty
+ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode
ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index de37e42a..e48f9bdd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -37,7 +37,7 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC.Core.Type ( Specificity(..) )
import GHC.Types.Basic (PromotionFlag(..), isPromoted)
-import GHC hiding (LexicalFixity(..))
+import GHC hiding (LexicalFixity(..), fromMaybeContext)
import GHC.Exts
import GHC.Types.Name
import GHC.Data.BooleanFormula
@@ -167,7 +167,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
leader' = leader <+> ppForAllPart unicode qual tele
do_args n leader (HsQualTy _ lctxt ltype)
- | null (unLoc lctxt)
+ | null (fromMaybeContext lctxt)
= do_largs n leader ltype
| otherwise
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
@@ -435,10 +435,12 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode
-> Qualification -> HideEmptyContexts -> Html
-ppLContext = ppContext . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContext Nothing u q h = ppContext [] u q h
+ppLContext (Just c) u q h = ppContext (unLoc c) u q h
+ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h
+ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h
ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
@@ -472,12 +474,12 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
-> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
+ <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
<+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
<+> ppFds fds unicode qual
@@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual
, con_ex_tvs = tyVars
, con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
@@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
, con_ex_tvs = tyVars
, con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
@@ -1181,13 +1183,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = Sho
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
- HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty t =
case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s
- HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsQualTy _ cxt _ -> null (fromMaybeContext cxt)
HsFunTy _ _ _ s -> isFirstContextEmpty s
_ -> False
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 10e13152..83711414 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -215,7 +215,7 @@ synifyTyCon prr _coax tc
, tcdDataDefn = HsDataDefn { dd_ext = noExtField
, dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
- , dd_ctxt = noLoc []
+ , dd_ctxt = Nothing
, dd_cType = Nothing
, dd_kindSig = synifyDataTyConReturnKind tc
-- we have their kind accurately:
@@ -377,7 +377,7 @@ synifyDataCon use_gadt_syntax dc =
-- skip any EqTheta, use 'orig'inal syntax
ctx | null theta = Nothing
- | otherwise = Just $ synifyCtx theta
+ | otherwise = synifyCtx theta
linear_tys =
zipWith (\ty bang ->
@@ -461,8 +461,8 @@ synifyTcIdSig vs (i, dm) =
mainSig t = synifySigType DeleteTopLevelQuantification vs t
defSig t = synifySigType ImplicitizeForAll vs t
-synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx = noLoc . map (synifyType WithinType [])
+synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)
+synifyCtx ts = Just (noLoc ( map (synifyType WithinType []) ts))
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 546e2941..6e21e094 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -24,7 +24,7 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char ( isSpace )
-import Data.Maybe ( mapMaybe )
+import Data.Maybe ( mapMaybe, fromMaybe )
import Haddock.Types( DocName, DocNameI )
@@ -172,7 +172,7 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
, sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
| otherwise
= tau_ty
@@ -226,10 +226,12 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
, hst_ctxt = add_ctxt ctxt, hst_body = ty })
go_ty (L loc ty)
= L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+ , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty })
extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
- add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+ add_ctxt Nothing = Just $ noLoc [extra_pred]
+ add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
@@ -355,7 +357,9 @@ reparenTypePrec = go
go p (HsQualTy x ctxt ty)
= let p' [_] = PREC_CTX
p' _ = PREC_TOP -- parens will get added anyways later...
- ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
+ ctxt' = case ctxt of
+ Nothing -> Nothing
+ Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c
in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
go p (HsFunTy x w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
@@ -758,3 +762,5 @@ defaultRuntimeRepVars = go emptyVarEnv
go _ ty@(LitTy {}) = ty
go _ ty@(CoercionTy {}) = ty
+fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
+fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b039e095..02fc86d9 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1108,9 +1108,9 @@ extractPatternSyn nm t tvs cons =
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ)
_ -> typ
- typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
+ typ'' = noLoc (HsQualTy noExtField Nothing typ')
in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b212adce..b62f79ce 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -258,7 +258,7 @@ renameType t = case t of
, hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
- lcontext' <- renameLContext lcontext
+ lcontext' <- traverse renameLContext lcontext
ltype' <- renameLType ltype
return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' })
@@ -432,7 +432,7 @@ renameTyClD d = case d of
ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
- lcontext' <- renameLContext lcontext
+ lcontext' <- traverse renameLContext lcontext
lname' <- renameL lname
ltyvars' <- renameLHsQTyVars ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
@@ -490,7 +490,7 @@ renameFamilyInfo (ClosedTypeFamily eqns)
renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)
renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k, dd_cons = cons }) = do
- lcontext' <- renameLContext lcontext
+ lcontext' <- traverse renameLContext lcontext
k' <- renameMaybeLKind k
cons' <- mapM (mapM renameCon) cons
-- I don't think we need the derivings, so we return Nothing
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index f37e1da9..5ef5d92d 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -284,7 +284,7 @@ renameType (HsForAllTy x tele lt) =
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
HsQualTy x
- <$> located renameContext lctxt
+ <$> renameMContext lctxt
<*> renameLType lt
renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
renameType t@(HsStarTy _ _) = pure t
@@ -325,6 +325,11 @@ renameLKind = renameLType
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
+renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))
+renameMContext Nothing = return Nothing
+renameMContext (Just (L l ctxt)) = do
+ ctxt' <- renameContext ctxt
+ return (Just (L l ctxt'))
renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 22:50:58 +0000