aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs13
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs16
-rw-r--r--haddock-api/src/Haddock/Convert.hs10
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs11
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs9
8 files changed, 33 insertions, 34 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e70a705f..3f913e09 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -280,7 +280,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 -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
+ Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = 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/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index abf882f0..fbae13a3 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -983,11 +983,12 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-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
+ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
+ppLContext Nothing _ = empty
+ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode
+
+ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX
+ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode
ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
@@ -1101,7 +1102,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
= sep [ ppHsForAllTelescope tele unicode
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
- = sep [ ppLContext ctxt unicode
+ = sep [ ppLContext (Just ctxt) unicode
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
= sep [ ppr_mono_lty ty1 u
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8de1b1b8..8ac1ac81 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -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 (fromMaybeContext lctxt)
+ | null (unLoc lctxt)
= do_largs n leader ltype
| otherwise
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
@@ -436,12 +436,14 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode
+ppLContext :: Maybe (LHsContext DocNameI) -> Unicode
-> Qualification -> HideEmptyContexts -> Html
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
+
+ppLContextNoArrow :: LHsContext DocNameI -> Unicode
+ -> Qualification -> HideEmptyContexts -> Html
+ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h
ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
@@ -1185,13 +1187,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = Sho
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
- HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True
+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty t =
case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s
- HsQualTy _ cxt _ -> null (fromMaybeContext cxt)
+ HsQualTy _ cxt _ -> null (unLoc cxt)
HsFunTy _ _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1230,7 +1232,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts
= ppForAllPart unicode qual tele <+> 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
+ = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 3a7ef57d..a2bdb1b9 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -124,7 +124,7 @@ tyThingToLHsDecl prr t = case t of
vs = tyConVisibleTyVars (classTyCon cl)
in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl
- { tcdCtxt = synifyCtx (classSCTheta cl)
+ { tcdCtxt = Just $ synifyCtx (classSCTheta cl)
, tcdLName = synifyNameN cl
, tcdTyVars = synifyTyVars vs
, tcdFixity = synifyFixity cl
@@ -302,7 +302,7 @@ synifyTyCon _prr coax tc
alg_deriv = []
defn = HsDataDefn { dd_ext = noExtField
, dd_ND = alg_nd
- , dd_ctxt = alg_ctx
+ , dd_ctxt = Just alg_ctx
, dd_cType = Nothing
, dd_kindSig = kindSig
, dd_cons = cons
@@ -375,7 +375,7 @@ synifyDataCon use_gadt_syntax dc =
-- skip any EqTheta, use 'orig'inal syntax
ctx | null theta = Nothing
- | otherwise = synifyCtx theta
+ | otherwise = Just $ synifyCtx theta
linear_tys =
zipWith (\ty bang ->
@@ -462,8 +462,8 @@ synifyTcIdSig vs (i, dm) =
mainSig t = synifySigType DeleteTopLevelQuantification vs t
defSig t = synifySigType ImplicitizeForAll vs t
-synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)
-synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))
+synifyCtx :: [PredType] -> LHsContext GhcRn
+synifyCtx ts = noLocA ( 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 1d6b8bc3..9353708a 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -171,7 +171,7 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
, sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
- = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })
+ = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
@@ -226,12 +226,11 @@ 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 Nothing, hst_body = L loc ty })
+ , hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty })
extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
- add_ctxt Nothing = Just $ noLocA [extra_pred]
- add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
@@ -356,9 +355,7 @@ reparenTypePrec = go
go p (HsQualTy x ctxt ty)
= let p' [_] = PREC_CTX
p' _ = PREC_TOP -- parens will get added anyways later...
- ctxt' = case ctxt of
- Nothing -> Nothing
- Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c
+ ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
-- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)
go p (HsFunTy x w ty1 ty2)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index a280c0b2..4f689532 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1146,9 +1146,9 @@ extractPatternSyn nm t tvs cons =
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ)
_ -> typ
- typ'' = noLocA (HsQualTy noExtField Nothing typ')
+ typ'' = noLocA (HsQualTy noExtField (noLocA []) typ')
in PatSynSig noAnn [noLocA 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 2833df49..693a22ef 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' <- traverse renameLContext lcontext
+ lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 16f00fda..657da7ae 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -283,7 +283,7 @@ renameType (HsForAllTy x tele lt) =
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
HsQualTy x
- <$> renameMContext lctxt
+ <$> renameLContext lctxt
<*> renameLType lt
renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
renameType t@(HsStarTy _ _) = pure t
@@ -324,11 +324,10 @@ 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
+renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)
+renameLContext (L l ctxt) = do
ctxt' <- renameContext ctxt
- return (Just (L l ctxt'))
+ return (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-27 08:49:15 +0000