From 66c1b9a37a2ddfc278e3635e4fa0aec297bcc1a0 Mon Sep 17 00:00:00 2001
From: mmzk1526 <yc4120@ic.ac.uk>
Date: Sun, 26 May 2024 21:25:19 +0100
Subject: [PATCH] Update Haddock
---
haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +--
.../src/Haddock/Backends/Hyperlinker/Utils.hs | 8 ++--
haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +--
.../src/Haddock/Backends/Xhtml/Decl.hs | 19 ++++----
haddock-api/src/Haddock/Convert.hs | 37 ++++++++-------
haddock-api/src/Haddock/GhcUtils.hs | 44 +++++++++---------
.../src/Haddock/Interface/AttachInstances.hs | 16 +++----
haddock-api/src/Haddock/Interface/Create.hs | 5 +-
haddock-api/src/Haddock/Interface/Rename.hs | 18 ++++---
.../src/Haddock/Interface/RenameType.hs | 11 +++--
haddock-library/src/.DS_Store | Bin 0 -> 6148 bytes
11 files changed, 93 insertions(+), 77 deletions(-)
create mode 100644 haddock-library/src/.DS_Store
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index b03269695c..81e9518778 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -95,7 +95,7 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
- drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
+ drop_ty (HsFunTy x m w a b) = HsFunTy x m w (drop_lty a) (drop_lty b)
drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c)
@@ -285,7 +285,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
[out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noExtField) x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noAnn hsMatchable (HsUnrestrictedArrow noExtField) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++
@@ -319,7 +319,7 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
tau_ty = foldr mkFunTy res_ty $
case args of PrefixConGADT _ pos_args -> map hsScaledThing pos_args
RecConGADT _ (L _ flds) -> map (cd_fld_type . unL) flds
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn hsMatchable (HsUnrestrictedArrow noExtField) a b)
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 35650feb3f..9a4774a188 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -127,10 +127,10 @@ recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
go (HTyVarTy n) = IfaceTyVar (getOccFS n)
go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
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 w a b) = IfaceFunTy (visArg TypeLike) w a b -- t1 -> t2
- go (HQualTy con b) = IfaceFunTy (invisArg TypeLike) many_ty con b -- c => t
+ go (HForAllTy ma ((n,k),af) t) = let b = (getOccFS n, k)
+ in IfaceForAllTy ma (Bndr (IfaceTvBndr b) af) t
+ go (HFunTy m w a b) = IfaceFunTy (visArg TypeLike) m w a b -- t1 -> t2
+ go (HQualTy con b) = IfaceFunTy (invisArg TypeLike) ifaceUnmatchable many_ty con b -- c => t
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 d5ba315d86..9175a52a00 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -523,13 +523,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ
, decltt (ppLContextNoArrow lctxt unicode) <+> nl
) : do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
+ do_args n leader (HsFunTy _ _m _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 _ _w lt r)
+ do_args n leader (HsFunTy _ _m _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
@@ -1141,7 +1141,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext (Just ctxt) unicode
, ppr_mono_lty ty unicode ]
-ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
+ppr_mono_ty (HsFunTy _ _ma mult ty1 ty2) u -- TODO (MMZK1526): Render matchability
= sep [ ppr_mono_lty ty1 u
, arr <+> ppr_mono_lty ty2 u ]
where arr = case mult of
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 30ec50fdcb..ce4656ca32 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -175,14 +175,14 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
+ do_args n leader (HsFunTy _ _m _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 _ _w lt r)
+ do_args n leader (HsFunTy _ _m _w lt r)
= (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
@@ -1196,15 +1196,15 @@ 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
- 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 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
@@ -1255,7 +1255,8 @@ 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 _ mult ty1 ty2) u q e =
+-- TODO (MMZK1526): pretty print using ma
+ppr_mono_ty (HsFunTy _ _ma mult ty1 ty2) u q e =
hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
, arr <+> ppr_mono_lty ty2 u q e
]
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2335f61b48..dccec84b63 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -54,7 +54,7 @@ import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
, liftedDataConKey, boxedRepDataConKey )
import GHC.Types.Unique ( getUnique )
import GHC.Utils.Misc ( chkAppend, dropList, equalLength
- , filterByList, filterOut )
+ , filterByList, filterOut, sndOf3 )
import GHC.Utils.Panic.Plain ( assert )
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -245,7 +245,7 @@ synifyTyCon prr _coax tc
| otherwise = noLocA $ KindedTyVar noAnn (HsBndrRequired noExtField) (noLocA (getName fakeTyVar)) (synifyKindSig realKind)
conKind = defaultType prr (tyConKind tc)
- tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind
+ tyVarKinds = sndOf3 . splitFunTys . snd . splitInvisPiTys $ conKind
synifyTyCon _prr _coax tc
| Just flav <- famTyConFlav_maybe tc
@@ -571,7 +571,7 @@ tyConArgsPolyKinded tc =
tc_vis_tvs = tyConVisibleTyVars tc
tc_res_kind_vis_bndrs :: [PiTyBinder]
- tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc
+ tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ sndOf3 $ splitPiTys $ tyConResKind tc
--states of what to do with foralls:
data SynifyTypeState
@@ -711,7 +711,7 @@ synifyType _ vs (TyConApp tc tys)
| otherwise = ty'
synifyType _ vs ty@(AppTy {}) = let
- (ty_head, ty_args) = splitAppTys ty
+ (ty_head, ty_args) = splitAppTys True ty
ty_head' = synifyType WithinType vs ty_head
ty_args' = map (synifyType WithinType vs) $
filterOut isCoercionTy $
@@ -719,15 +719,16 @@ synifyType _ vs ty@(AppTy {}) = let
ty_args
in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'
-synifyType s vs funty@(FunTy af w t1 t2)
+synifyType s vs funty@(FunTy af m w t1 t2)
| isInvisibleFunArg af = synifySigmaType s vs funty
- | otherwise = noLocA $ HsFunTy noAnn w' s1 s2
+ | otherwise = noLocA $ HsFunTy noAnn m' w' s1 s2
where
s1 = synifyType WithinType vs t1
s2 = synifyType WithinType vs t2
+ m' = synifyMatchability vs m
w' = synifyMult vs w
-synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
+synifyType s vs forallty@(ForAllTy _ (Bndr _ argf) _ty) =
case argf of
Required -> synifyVisForAllType vs forallty
Invisible _ -> synifySigmaType s vs forallty
@@ -750,7 +751,7 @@ synifyVisForAllType vs ty =
-- absence of an explicit forall
tvs' = orderedFVs (mkVarSet vs) [rho]
- in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs
+ in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn hsUnmatchable sTvs
, hst_xforall = noExtField
, hst_body = synifyType WithinType (tvs' ++ vs) rho }
@@ -838,11 +839,11 @@ noKindTyVars
noKindTyVars _ (TyVarTy var)
| isLiftedTypeKind (tyVarKind var) = unitVarSet var
noKindTyVars ts ty
- | (f, xs) <- splitAppTys ty
+ | (f, xs) <- splitAppTys True ty
, not (null xs)
= let args = map (noKindTyVars ts) xs
func = case f of
- TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var)
+ TyVarTy var | (_, xsKinds, outKind) <- splitFunTys (tyVarKind var)
, map scaledThing xsKinds `eqTypes` map typeKind xs
, isLiftedTypeKind outKind
-> unitVarSet var
@@ -851,8 +852,8 @@ noKindTyVars ts ty
-> mkVarSet [ v | TyVarTy v <- xs ]
_ -> noKindTyVars ts f
in unionVarSets (func : args)
-noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t
-noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet`
+noKindTyVars ts (ForAllTy ma _ t) = noKindTyVars ts ma `unionVarSet`noKindTyVars ts t
+noKindTyVars ts (FunTy _ m w t1 t2) = noKindTyVars ts m `unionVarSet` noKindTyVars ts w `unionVarSet`
noKindTyVars ts t1 `unionVarSet`
noKindTyVars ts t2
noKindTyVars ts (CastTy t _) = noKindTyVars ts t
@@ -864,7 +865,11 @@ synifyMult vs t = case t of
ManyTy -> HsUnrestrictedArrow noExtField
ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
-
+synifyMatchability :: [TyVar] -> Matchability -> HsMatchability GhcRn
+synifyMatchability vs t = case t of
+ Matchable -> hsMatchable
+ Unmatchable -> hsUnmatchable
+ ty -> HsExplicitMatchability (synifyType WithinType vs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType ps =
@@ -881,7 +886,7 @@ synifyPatSynType ps =
in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta'
(\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))
- (mkScaledFunTys arg_tys res_ty)
+ (mkScaledFunTysU arg_tys res_ty)
synifyTyLit :: TyLit -> HsTyLit GhcRn
synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
@@ -986,7 +991,7 @@ tcSplitSomeForAllTysPreserveSynonyms ::
(ForAllTyFlag -> Bool) -> Type -> ([ForAllTyBinder], Type)
tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty []
where
- split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs
+ split _ (ForAllTy _ tvb@(Bndr _ argf) ty') tvs
| argf_pred argf = split ty' ty' (tvb:tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
@@ -1029,6 +1034,6 @@ tcSplitPhiTyPreserveSynonyms ty0 = split ty0 []
-- | See Note [Invariant: Never expand type synonyms]
tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)
-tcSplitPredFunTyPreserveSynonyms_maybe (FunTy af _ arg res)
+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy af _ _ arg res)
| isInvisibleFunArg af = Just (arg, res)
tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 0fa25abb26..c0e908d217 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -203,7 +203,7 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
PrefixConGADT _ pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn HsAmbiguousMatchability (HsUnrestrictedArrow noExtField) a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -377,8 +377,8 @@ reparenTypePrec = go
p' _ = PREC_TOP -- parens will get added anyways later...
ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
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)
+ go p (HsFunTy x m w ty1 ty2)
+ = paren p PREC_FUN $ HsFunTy x m w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
= paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
go p (HsAppKindTy x fun_ty arg_ki)
@@ -431,8 +431,8 @@ reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
reparenHsForAllTelescope :: forall a. (XRecCond a )
=> HsForAllTelescope a -> HsForAllTelescope a
-reparenHsForAllTelescope (HsForAllVis x bndrs) =
- HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
+reparenHsForAllTelescope (HsForAllVis x ma bndrs) =
+ HsForAllVis x ma (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope (HsForAllInvis x bndrs) =
HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
@@ -680,9 +680,9 @@ typeNames ty = go ty Set.empty
case t of
TyVarTy {} -> acc
AppTy t1 t2 -> go t2 $ go t1 acc
- FunTy _ _ t1 t2 -> go t2 $ go t1 acc
+ FunTy _ _ _ t1 t2 -> go t2 $ go t1 acc
TyConApp tcon args -> foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args
- ForAllTy bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc
+ ForAllTy _ bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc
LitTy _ -> acc
CastTy t' _ -> go t' acc
CoercionTy {} -> acc
@@ -726,16 +726,17 @@ orderedFVs vs tys =
-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order
-- of appearance.
tyCoFVsOfType' :: Type -> FV
-tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c
-tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c
-tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c
-tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
-tyCoFVsOfType' (FunTy _ w arg res) a b c = (tyCoFVsOfType' w `unionFV`
- tyCoFVsOfType' res `unionFV`
- tyCoFVsOfType' arg) a b c
-tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c
-tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c
-tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c
+tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c
+tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c
+tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c
+tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
+tyCoFVsOfType' (FunTy _ m w arg res) a b c = (tyCoFVsOfType' m `unionFV`
+ tyCoFVsOfType' w `unionFV`
+ tyCoFVsOfType' res `unionFV`
+ tyCoFVsOfType' arg) a b c
+tyCoFVsOfType' (ForAllTy ma bndr ty) a b c = (tyCoFVsOfType' ma `unionFV` tyCoFVsBndr' bndr (tyCoFVsOfType' ty)) a b c
+tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c
+tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c
-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order
-- of appearance.
@@ -760,13 +761,14 @@ defaultRuntimeRepVars :: Type -> Type
defaultRuntimeRepVars = go emptyVarEnv
where
go :: TyVarEnv () -> Type -> Type
- go subs (ForAllTy (Bndr var flg) ty)
+ go subs (ForAllTy ma (Bndr var flg) ty)
| isRuntimeRepVar var
, isInvisibleForAllTyFlag flg
= let subs' = extendVarEnv subs var ()
in go subs' ty
| otherwise
- = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg)
+ = ForAllTy (go subs ma)
+ (Bndr (updateTyVarKind (go subs) var) flg)
(go subs ty)
go subs (TyVarTy tv)
@@ -778,8 +780,8 @@ defaultRuntimeRepVars = go emptyVarEnv
go subs (TyConApp tc tc_args)
= TyConApp tc (map (go subs) tc_args)
- go subs (FunTy af w arg res)
- = FunTy af (go subs w) (go subs arg) (go subs res)
+ go subs (FunTy af m w arg res)
+ = FunTy af (go subs m) (go subs w) (go subs arg) (go subs res)
go subs (AppTy t u)
= AppTy (go subs t) (go subs u)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 9120d293cc..fb6188f12f 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -319,16 +319,16 @@ instHead (_, _, cls, args)
= (map argCount args, SName (className cls), map simplify args)
argCount :: Type -> Int
-argCount (AppTy t _) = argCount t + 1
-argCount (TyConApp _ ts) = length ts
-argCount (FunTy _ _ _ _) = 2
-argCount (ForAllTy _ t) = argCount t
-argCount (CastTy t _) = argCount t
-argCount _ = 0
+argCount (AppTy t _) = argCount t + 1
+argCount (TyConApp _ ts) = length ts
+argCount (FunTy _ _ _ _ _) = 2
+argCount (ForAllTy _ _ t) = argCount t
+argCount (CastTy t _) = argCount t
+argCount _ = 0
simplify :: Type -> SimpleType
-simplify (FunTy _ _ t1 t2) = SimpleType (SName unrestrictedFunTyConName) [simplify t1, simplify t2]
-simplify (ForAllTy _ t) = simplify t
+simplify (FunTy _ _ _ t1 t2) = SimpleType (SName unrestrictedFunTyConName) [simplify t1, simplify t2]
+simplify (ForAllTy _ _ t) = simplify t
simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) []
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 68e0872332..e164309aa3 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -67,7 +67,6 @@ import GHC.Utils.Panic (pprPanic)
import GHC.Driver.Ppr
import GHC.Unit.Module.ModIface
import GHC.Builtin.Names
-import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Types.SafeHaskell
import Control.Arrow ((&&&))
@@ -780,7 +779,7 @@ extractPatternSyn nm t tvs cons =
in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn HsAmbiguousMatchability (HsUnrestrictedArrow noExtField) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
@@ -797,7 +796,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) data_ty (getBangType ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn HsAmbiguousMatchability (HsUnrestrictedArrow noExtField) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 736141659e..95ac0593ba 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -334,6 +334,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-> RnM (Maybe (LInjectivityAnn DocNameI))
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
+renameMatchability :: HsMatchability GhcRn -> RnM (HsMatchability DocNameI)
+renameMatchability (HsExplicitMatchability p) = HsExplicitMatchability <$> renameLType p
+renameMatchability HsAmbiguousMatchability = pure HsAmbiguousMatchability
+
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
renameArrow (HsUnrestrictedArrow _) = return (HsUnrestrictedArrow noExtField)
renameArrow (HsLinearArrow _) = return (HsLinearArrow noExtField)
@@ -367,11 +371,12 @@ renameType t = case t of
b' <- renameLKind b
return (HsAppKindTy noAnn a' b')
- HsFunTy _ w a b -> do
+ HsFunTy _ m w a b -> do
a' <- renameLType a
b' <- renameLType b
+ m' <- renameMatchability m
w' <- renameArrow w
- return (HsFunTy noAnn w' a' b')
+ return (HsFunTy noAnn m' w' a' b')
HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty
HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty)
@@ -448,10 +453,11 @@ renameHsBndrVis (HsBndrInvisible at) = return (HsBndrInvisible at)
renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)
renameHsForAllTelescope tele = case tele of
- HsForAllVis _ bndrs -> do bndrs' <- mapM (renameLTyVarBndr return) bndrs
- pure $ HsForAllVis noExtField bndrs'
- HsForAllInvis _ bndrs -> do bndrs' <- mapM (renameLTyVarBndr return) bndrs
- pure $ HsForAllInvis noExtField bndrs'
+ HsForAllVis _ ma bndrs -> do ma' <- renameMatchability ma
+ bndrs' <- mapM (renameLTyVarBndr return) bndrs
+ pure $ HsForAllVis noExtField ma' bndrs'
+ HsForAllInvis _ bndrs -> do bndrs' <- mapM (renameLTyVarBndr return) bndrs
+ pure $ HsForAllInvis noExtField bndrs'
renameLTyVarBndr :: (flag -> RnM flag') -> LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag' DocNameI)
renameLTyVarBndr rn_flag (L loc (UserTyVar _ fl (L l n)))
diff --git a/haddock-api/src/Haddock/Interface/RenameType.hs b/haddock-api/src/Haddock/Interface/RenameType.hs
index 64b3de7f76..68856622e0 100644
--- a/haddock-api/src/Haddock/Interface/RenameType.hs
+++ b/haddock-api/src/Haddock/Interface/RenameType.hs
@@ -104,7 +104,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
-renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr
+renameType (HsFunTy x m w la lr) = HsFunTy x <$> renameHsMatchability m <*> renameHsArrow w <*> renameLType la <*> renameLType lr
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
@@ -125,11 +125,14 @@ renameType (HsExplicitTupleTy x ltys) =
renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
+renameHsMatchability :: HsMatchability GhcRn -> Rename (IdP GhcRn) (HsMatchability GhcRn)
+renameHsMatchability (HsExplicitMatchability p) = HsExplicitMatchability <$> renameLType p
+renameHsMatchability ma = pure ma
+
renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
renameHsArrow (HsExplicitMult x p) = HsExplicitMult x <$> renameLType p
renameHsArrow mult = pure mult
-
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
@@ -149,8 +152,8 @@ renameContext = renameLTypes
renameForAllTelescope :: HsForAllTelescope GhcRn
-> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)
-renameForAllTelescope (HsForAllVis x bndrs) =
- HsForAllVis x <$> mapM renameLBinder bndrs
+renameForAllTelescope (HsForAllVis x ma bndrs) =
+ HsForAllVis x ma <$> mapM renameLBinder bndrs
renameForAllTelescope (HsForAllInvis x bndrs) =
HsForAllInvis x <$> mapM renameLBinder bndrs
diff --git a/haddock-library/src/.DS_Store b/haddock-library/src/.DS_Store
new file mode 100644
index 0000000000000000000000000000000000000000..1d71478efc2243e5ffffe8e5e6987881c528868d
GIT binary patch
literal 6148
zcmeHK&u`N(6n@?cX*x~H0i<1!B5|!o*{Vqsm#ixi+z>%<092ACqS3OrY7%;=D&-7+
z3|IaV{vG(9?MY3`uM<Mdud+Y;`F(c%xwdN}5~DhKNaPVw7m2acL-qsXc1~NiV>}K}
zs6Ha9=o!r^rF<*eI;;X#fqzW_-n$;1lcXz}(fa<aDZxHIq$!n8b9oWxGFGu9?g0<K
zDO1zgr!n{!RHKiS3Y-DlPX=GnX42UP)1fDbP4Hp<<wo@9Uq{D_a%R5Omw1+EWi=Rl
z6+63~Tels@b@rUM;Z!cdDyr&o6wP0A?S+(id|i&>msz@)cz4caQAJsi&J`g`QiQyD
zl@*CxjAUITrQ(LV!F9Xt#5-6nkA^3G|9E)1>if&nqe0&v9-pjMZujo}2aldlF7vBG
zepLF9!0D)L-{3WTLSaLL58=GXW$_*@%<8oj`lI#eVa?W51*fEGTU)^+udgAh)^3;r
z=2zL>yJ7RT)3pj%1%9sppAS9~V_>k+sE!U~>Inesz^x2reoHXNHy9XfG@=D2G!>|+
z!aOmAro-=>xWHheQPWA7$A>T@3-dw|YIOAPt8fy5Mw?p&tO9KXc6HU``~UIJ-~Vlr
ztyu-E0{@i)qB9Q1BTUKMty`1hyVgf~hs4HljYdU5X0BsZ;H&rmNg3LFE&v0AjYfE2
P_K$#)!Dd#0zpB7@xFL~b
literal 0
HcmV?d00001
--
GitLab