aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/GhcUtils.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs84
1 files changed, 38 insertions, 46 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 41801710..b8db6dfd 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -26,7 +26,7 @@ import Control.Arrow
import Data.Char ( isSpace )
import Data.Maybe ( mapMaybe, fromMaybe )
-import Haddock.Types( DocName, DocNameI )
+import Haddock.Types( DocName, DocNameI, XRecCond )
import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable )
@@ -44,7 +44,6 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet )
import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import GHC.Core.TyCo.Rep ( Type(..) )
import GHC.Core.Type ( isRuntimeRepVar )
-import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import GHC.Builtin.Types( liftedRepTy )
import GHC.Data.StringBuffer ( StringBuffer )
@@ -75,20 +74,20 @@ filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p (FixSig _ (FixitySig _ ns ty)) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty))
+ filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty))
filterSigNames _ orig@(MinimalSig _ _ _) = Just orig
filterSigNames p (TypeSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig noExtField filtered ty)
+ filtered -> Just (TypeSig noAnn filtered ty)
filterSigNames p (ClassOpSig _ is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (ClassOpSig noExtField is_default filtered ty)
+ filtered -> Just (ClassOpSig noAnn is_default filtered ty)
filterSigNames p (PatSynSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (PatSynSig noExtField filtered ty)
+ filtered -> Just (PatSynSig noAnn filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -127,7 +126,7 @@ hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n
hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName
hsLTyVarNameI = hsTyVarNameI . unLoc
-getConNamesI :: ConDecl DocNameI -> [Located DocName]
+getConNamesI :: ConDecl DocNameI -> [LocatedN DocName]
getConNamesI ConDeclH98 {con_name = name} = [name]
getConNamesI ConDeclGADT {con_names = names} = names
@@ -167,21 +166,22 @@ getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty })
- = noLoc (HsSig { sig_ext = noExtField
- , sig_bndrs = outer_bndrs
- , sig_body = theta_ty })
+ = noLocA (HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs
+ , sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
+ = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })
| otherwise
= tau_ty
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+ RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
- mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
+ mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -197,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinderI _ = []
-familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName
+familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName
familyDeclLNameI (FamilyDecl { fdLName = n }) = n
-tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName
+tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName
tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd
tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln
tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln
@@ -212,7 +212,7 @@ tcdNameI = unLoc . tyClDeclLNameI
addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
-- Add the class context to a class-op signature
addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
- = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
+ = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
where
go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
= L loc (HsSig { sig_ext = noExtField
@@ -230,14 +230,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
- add_ctxt Nothing = Just $ noLoc [extra_pred]
+ add_ctxt Nothing = Just $ noLocA [extra_pred]
add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes tvs
- = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
@@ -332,14 +332,13 @@ data Precedence
--
-- We cannot add parens that may be required by fixities because we do not have
-- any fixity information to work with in the first place :(.
-reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenTypePrec :: forall a. (XRecCond a)
=> Precedence -> HsType a -> HsType a
reparenTypePrec = go
where
-- Shorter name for 'reparenType'
- go :: Precedence -> HsType a -> HsType a
+ go :: XParTy a ~ ApiAnn' AnnParen => Precedence -> HsType a -> HsType a
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
@@ -361,6 +360,7 @@ reparenTypePrec = go
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)
+ -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType 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 (HsAppTy x fun_ty arg_ty)
@@ -378,40 +378,35 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
- goL :: Precedence -> LHsType a -> LHsType a
+ goL :: XParTy a ~ ApiAnn' AnnParen => Precedence -> LHsType a -> LHsType a
goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens
- paren :: Precedence -- Precedence of context
+ paren :: XParTy a ~ ApiAnn' AnnParen
+ => Precedence -- Precedence of context
-> Precedence -- Precedence of top-level operator
-> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)
- paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a
+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a
| otherwise = id
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => HsType a -> HsType a
+reparenType :: XRecCond a => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => LHsType a -> LHsType a
+reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a
reparenLType = mapXRec @a reparenType
-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
-reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenSigType :: forall a. ( XRecCond a )
=> HsSigType a -> HsSigType a
reparenSigType (HsSig x bndrs body) =
HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)
reparenSigType v@XHsSigType{} = v
-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
-reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )
=> HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
@@ -419,8 +414,7 @@ reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenHsForAllTelescope :: forall a. (XRecCond a )
=> HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis x bndrs) =
HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
@@ -429,17 +423,13 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => ConDeclField a -> ConDeclField a
+reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c
@@ -449,13 +439,15 @@ reparenConDeclField c@XConDeclField{} = c
-------------------------------------------------------------------------------
-unL :: Located a -> a
+unL :: GenLocated l a -> a
unL (L _ x) = x
-
-reL :: a -> Located a
+reL :: a -> GenLocated l a
reL = L undefined
+mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)
+mapMA f (L al a) = L (locA al) <$> f a
+
-------------------------------------------------------------------------------
-- * NamedThing instances
-------------------------------------------------------------------------------
@@ -763,4 +755,4 @@ defaultRuntimeRepVars = go emptyVarEnv
go _ ty@(CoercionTy {}) = ty
fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
-fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt
+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 17:10:04 +0000