aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/Create.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs41
1 files changed, 22 insertions, 19 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 4e788260..a280c0b2 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -79,6 +79,8 @@ import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..))
import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
+import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.Unit.Module.Warnings
newtype IfEnv m = IfEnv
{
@@ -200,7 +202,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
loc_splices :: [SrcSpan]
loc_splices = case tcg_rn_decls of
Nothing -> []
- Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]
+ Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ]
decls <- case tcg_rn_decls of
Nothing -> do
@@ -530,7 +532,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
, [(Name, IntMap (MDoc Name))]
, [(Name, [LHsDecl GhcRn])]
)
- mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do
+ mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do
let declDoc :: [HsDocString] -> IntMap HsDocString
-> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))
declDoc strs m = do
@@ -559,7 +561,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
seqList subDocs `seq`
seqList subArgs `seq`
pure (dm, am, cm)
- mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])
+ mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], [])
instanceMap :: Map RealSrcSpan Name
instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
@@ -570,7 +572,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
-- The CoAx's loc is the whole line, but only for TFs. The
-- workaround is to dig into the family instance declaration and
-- get the identifier with the right location.
- TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d')
+ TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -701,7 +703,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let t = availName avail
r <- findDecl avail
case r of
- ([L l (ValD _ _)], (doc, _)) -> do
+ ([L l' (ValD _ _)], (doc, _)) -> do
+ let l = locA l'
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
@@ -734,7 +737,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
L loc (TyClD _ ClassDecl {..}) -> do
mdef <- minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef
availExportDecl avail
(L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
@@ -892,7 +895,7 @@ hiDecl dflags t = do
Just x -> case tyThingToLHsDecl ShowRuntimeRep x of
Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
Right (m, t') -> liftErrMsg (tell $ map bugWarn m)
- >> return (Just $ noLoc t')
+ >> return (Just $ noLocA t')
where
warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
O.comma O.<+> O.quotes (O.ppr t) O.<+>
@@ -912,7 +915,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do
Nothing -> return (ExportNoDecl name [])
Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
where
- fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
+ fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t
fixities = case fixity of
Just f -> [(name, f)]
Nothing -> []
@@ -1101,7 +1104,7 @@ extractDecl declMap name decl
, name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))
+ [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))
_ -> Left "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches = [ d' | L _ d'@(DataFamInstDecl d )
@@ -1113,7 +1116,7 @@ extractDecl declMap name decl
, extFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)
+ [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
_ -> Left "internal: extractDecl (ClsInstD)"
_ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
@@ -1143,21 +1146,21 @@ extractPatternSyn nm t tvs cons =
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)
_ -> typ
- typ'' = noLoc (HsQualTy noExtField (Just (noLoc [])) typ')
- in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
+ typ'' = noLocA (HsQualTy noExtField Nothing typ')
+ in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs
where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty
mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki
- mkAppTyArg f (HsArgPar _) = HsParTy noExtField f
+ mkAppTyArg f (HsArgPar _) = HsParTy noAnn f
extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
-> Either ErrMsg (LSig GhcRn)
@@ -1166,7 +1169,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 l (TypeSig noExtField [noLoc nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
@@ -1175,11 +1178,11 @@ extractRecSel nm t tvs (L _ con : rest) =
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs
where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty
mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki
- mkAppTyArg f (HsArgPar _) = HsParTy noExtField f
+ mkAppTyArg f (HsArgPar _) = HsParTy noAnn f
-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 01:43:01 +0000