aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs8
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs7
-rw-r--r--haddock-api/src/Haddock/Convert.hs16
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs10
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs16
-rw-r--r--haddock-api/src/Haddock/Types.hs6
-rw-r--r--haddock-api/src/Haddock/Utils.hs2
10 files changed, 40 insertions, 37 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 48b97445..40106491 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -16,7 +16,7 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-import BasicTypes (OverlapFlag(..), OverlapMode(..))
+import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
import InstEnv (ClsInst(..))
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
@@ -85,7 +85,7 @@ dropHsDocTy = f
f (HsDocTy a _) = f $ unL a
f x = x
-outHsType :: (OutputableBndr a, OutputableBndr (NameOrRdrName a))
+outHsType :: (OutputableBndrId a, HasOccNameId a)
=> DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
@@ -196,7 +196,7 @@ ppInstance dflags x =
-- safety information to a state where the Outputable instance
-- produces no output which means no overlap and unsafe (or [safe]
-- is generated).
- cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty
+ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText
, isSafeOverlap = False } }
ppSynonym :: DynFlags -> TyClDecl Name -> [String]
@@ -244,7 +244,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- resType = apps $ map (reL . HsTyVar . reL) $
+ resType = apps $ map (reL . HsTyVar NotPromoted . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@ConDeclGADT {}
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index be17cb8b..1d9fbe20 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -72,7 +72,7 @@ types =
everything (<|>) ty
where
ty term = case cast term of
- (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+ (Just (GHC.L sspan (GHC.HsTyVar _ name))) ->
pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index ffb4d782..36a859e6 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -949,7 +949,8 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
, ppr_mono_lty pREC_TOP ty unicode ]
ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys)
@@ -960,7 +961,8 @@ ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index c6f1100b..499d9e11 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -984,12 +984,12 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar (L _ name)) True _
+ppr_mono_ty _ (HsTyVar _ (L _ name)) True _
| getOccString (getName name) == "*" = toHtml "★"
| getOccString (getName name) == "(->)" = toHtml "(→)"
ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name
+ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys)
@@ -1005,7 +1005,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
-- placeholder in the signature, which is followed by the field
-- declarations.
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys
ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4e2ee05c..a99c5886 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -17,7 +17,7 @@ module Haddock.Convert where
-- instance heads, which aren't TyThings, so just export everything.
import Bag ( emptyBag )
-import BasicTypes ( TupleSort(..) )
+import BasicTypes ( TupleSort(..), SourceText(..) )
import Class
import CoAxiom
import ConLike
@@ -80,7 +80,7 @@ tyThingToLHsDecl t = case t of
, tcdFDs = map (\ (l,r) -> noLoc
(map (noLoc . getName) l, map (noLoc . getName) r) ) $
snd $ classTvsFds cl
- , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) :
+ , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)
(classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -366,17 +366,17 @@ synifyPatSynSigType :: PatSyn -> LHsSigType Name
synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
-- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
, lev `hasKey` ptrRepLiftedDataConKey
- = noLoc (HsTyVar (noLoc starKindTyConName))
+ = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
, lev `hasKey` ptrRepUnliftedDataConKey
- = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName))
+ = noLoc (HsTyVar NotPromoted (noLoc unliftedTypeKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
@@ -400,7 +400,7 @@ synifyType _ (TyConApp tc tys)
-- Most TyCons:
| otherwise =
foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
- (noLoc $ HsTyVar $ noLoc (getName tc))
+ (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc))
(map (synifyType WithinType) $
filterOut isCoercionTy tys)
synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
@@ -443,8 +443,8 @@ synifyPatSynType ps = let
in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
synifyTyLit :: TyLit -> HsTyLit
-synifyTyLit (NumTyLit n) = HsNumTy mempty n
-synifyTyLit (StrTyLit s) = HsStrTy mempty s
+synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
+synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 2cdc6f8b..4e1a9b3a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -48,7 +48,7 @@ import Bag
import RdrName
import TcRnTypes
import FastString (concatFS)
-import BasicTypes ( StringLiteral(..) )
+import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
import HsDecls ( gadtDeclDetails,getConDetails )
@@ -164,7 +164,7 @@ mkAliasMap dflags mRenamedSource =
Just (_,impDecls,_,_) ->
M.fromList $
mapMaybe (\(SrcLoc.L _ impDecl) -> do
- alias <- ideclAs impDecl
+ SrcLoc.L _ alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
(fmap Module.fsToUnitId $
@@ -569,7 +569,7 @@ mkExportItems
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
return [ mkExportDecl t
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
@@ -769,7 +769,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
expInst decl l name
mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
mkExportItem decl@(L l d)
| name:_ <- getMainDeclBinder d = expDecl decl l name
@@ -839,7 +839,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty
-- | ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index fa85ba64..40a10675 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -219,7 +219,7 @@ renameType t = case t of
ltype' <- renameLType ltype
return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n
+ HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
HsAppTy a b -> do
@@ -262,7 +262,7 @@ renameType t = case t of
HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
HsCoreTy a -> pure (HsCoreTy a)
- HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 3e0df4e1..28bbf305 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name)
specialize name details =
everywhere $ mkT step
where
- step (HsTyVar (L _ name')) | name == name' = details
+ step (HsTyVar _ (L _ name')) | name == name' = details
step typ = typ
@@ -123,7 +123,7 @@ sugar =
sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
+sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
name' = getName name
@@ -137,7 +137,7 @@ sugarTuples typ =
where
aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy (L _ typ')) = aux apps typ'
- aux apps (HsTyVar (L _ name))
+ aux apps (HsTyVar _ (L _ name))
| isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
where
name' = getName name
@@ -149,7 +149,7 @@ sugarTuples typ =
sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)
+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
where
@@ -224,7 +224,7 @@ freeVariables =
query term ctx = case cast term :: Maybe (HsType name) of
Just (HsForAllTy bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar (L _ name))
+ Just (HsTyVar _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getNameRep name, ctx)
_ -> (Set.empty, ctx)
@@ -267,7 +267,7 @@ renameType (HsQualTy lctxt lt) =
HsQualTy
<$> located renameContext lctxt
<*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> located renameName name
+renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
renameType (HsListTy lt) = HsListTy <$> renameLType lt
@@ -285,8 +285,8 @@ renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
renameType t@(HsRecTy _) = pure t
renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ph ltys) =
- HsExplicitListTy ph <$> renameLTypes ltys
+renameType (HsExplicitListTy ip ph ltys) =
+ HsExplicitListTy ip ph <$> renameLTypes ltys
renameType (HsExplicitTupleTy phs ltys) =
HsExplicitTupleTy phs <$> renameLTypes ltys
renameType t@(HsTyLit _) = pure t
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 5220e6e9..951faf5b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -344,7 +344,7 @@ data InstType name
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
-instance (OutputableBndr a, OutputableBndr (NameOrRdrName a))
+instance (OutputableBndrId a, HasOccNameId a)
=> Outputable (InstType a) where
ppr (ClassInst { .. }) = text "ClassInst"
<+> ppr clsiCtx
@@ -380,8 +380,8 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
mkType (KindedTyVar (L loc name) lkind) =
HsKindSig tvar lkind
where
- tvar = L loc (HsTyVar (L loc name))
- mkType (UserTyVar name) = HsTyVar name
+ tvar = L loc (HsTyVar NotPromoted (L loc name))
+ mkType (UserTyVar name) = HsTyVar NotPromoted name
-- | An instance head that may have documentation and a source location.
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index da87990c..ba382600 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))
+ = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 10:53:53 +0000