aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs41
-rw-r--r--haddock-api/src/Haddock/Interface.hs1
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs1
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs184
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs1
5 files changed, 4 insertions, 224 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index e4d7c2b6..3abb6481 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -56,32 +56,6 @@ moduleString = moduleNameString . moduleName
isNameSym :: Name -> Bool
isNameSym = isSymOcc . nameOccName
-getMainDeclBinder :: (CollectPass (GhcPass p)) => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
-getMainDeclBinder (TyClD _ d) = [tcdName d]
-getMainDeclBinder (ValD _ d) =
- case collectHsBindBinders d of
- [] -> []
- (name:_) -> [name]
-getMainDeclBinder (SigD _ d) = sigNameNoLoc d
-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
-getMainDeclBinder _ = []
-
--- Extract the source location where an instance is defined. This is used
--- to correlate InstDecls with their Instance/CoAxiom Names, via the
--- instanceMap.
-getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
-getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD _ (DataFamInstDecl
- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
-getInstLoc (TyFamInstD _ (TyFamInstDecl
- -- Since CoAxioms' Names refer to the whole line for type family instances
- -- in particular, we need to dig a bit deeper to pull out the entire
- -- equation. This does not happen for data family instances, for some reason.
- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
-
-
-
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
-- but only one of the names is exported and we have to change the
@@ -139,24 +113,9 @@ isClassD :: HsDecl a -> Bool
isClassD (TyClD _ d) = isClassDecl d
isClassD _ = False
-isValD :: HsDecl a -> Bool
-isValD (ValD _ _) = True
-isValD _ = False
-
pretty :: Outputable a => DynFlags -> a -> String
pretty = showPpr
-nubByName :: (a -> Name) -> [a] -> [a]
-nubByName f ns = go emptyNameSet ns
- where
- go !_ [] = []
- go !s (x:xs)
- | y `elemNameSet` s = go s xs
- | otherwise = let !s' = extendNameSet s y
- in x : go s' xs
- where
- y = f x
-
-- ---------------------------------------------------------------------
-- These functions are duplicated from the GHC API, as they must be
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 255cbdbc..fa20b836 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -61,6 +61,7 @@ import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
import GHC.Types.Name.Occurrence (isTcOcc)
import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts)
import GHC.Utils.Error (withTimingD)
+import GHC.HsToCore.Docs
#if defined(mingw32_HOST_OS)
import System.IO
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 7deb67f9..0840bd77 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -44,6 +44,7 @@ import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Builtin.Types.Prim( funTyConName )
import GHC.Types.Var hiding (varName)
+import GHC.HsToCore.Docs
type ExportedNames = Set.Set Name
type Modules = Set.Set Module
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index eb3354a4..7b9674a6 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -55,6 +55,7 @@ import GHC.Tc.Types
import GHC.Data.FastString ( unpackFS, bytesFS )
import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified GHC.Utils.Outputable as O
+import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Core.Multiplicity
@@ -436,109 +437,6 @@ mkMaps dflags pkgName gre instances decls = do
--------------------------------------------------------------------------------
--- | Get all subordinate declarations inside a declaration, and their docs.
--- A subordinate declaration is something like the associate type or data
--- family of a type class.
-subordinates :: InstMap
- -> HsDecl GhcRn
- -> [(Name, [HsDocString], Map Int HsDocString)]
-subordinates instMap decl = case decl of
- InstD _ (ClsInstD _ d) -> do
- DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_tycon = L l _
- , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
- [ (n, [], M.empty) | Just n <- [SrcLoc.lookupSrcSpan l instMap] ] ++ dataSubs defn
-
- InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
- -> dataSubs (feqn_rhs d)
- TyClD _ d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
- _ -> []
- where
- classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
- , name <- getMainDeclBinder d, not (isValD d)
- ]
- dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
- dataSubs dd = constrs ++ fields ++ derivs
- where
- cons = map unL $ (dd_cons dd)
- constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
- | c <- cons, cname <- getConNames c ]
- fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
- | RecCon flds <- map getConArgs cons
- , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
- , L _ n <- ns ]
- derivs = [ (instName, [unL doc], M.empty)
- | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
- concatMap (unLoc . deriv_clause_tys . unLoc) $
- unLoc $ dd_derivs dd
- , Just instName <- [SrcLoc.lookupSrcSpan l instMap] ]
-
- extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
- extract_deriv_ty (L l ty) =
- case ty of
- -- deriving (forall a. C a {- ^ Doc comment -})
- HsForAllTy{ hst_tele = HsForAllInvis{}
- , hst_body = L _ (HsDocTy _ _ doc) }
- -> Just (l, doc)
- -- deriving (C a {- ^ Doc comment -})
- HsDocTy _ _ doc -> Just (l, doc)
- _ -> Nothing
-
--- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
-conArgDocs con = case getConArgs con of
- PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)
- InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),
- unLoc (hsScaledThing arg2)] ++ ret)
- RecCon _ -> go 1 ret
- where
- go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
- go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys
- go n (_ : tys) = go (n+1) tys
- go _ [] = M.empty
-
- ret = case con of
- ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
- _ -> []
-
--- | Extract function argument docs from inside top-level decls.
-declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
-declTypeDocs _ = M.empty
-
--- | Extract function argument docs from inside types.
-typeDocs :: HsType GhcRn -> Map Int HsDocString
-typeDocs = go 0
- where
- go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
- go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
- go n (HsFunTy _ _w (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
- go n (HsFunTy _ _ _ ty) = go (n+1) (unLoc ty)
- go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
- go _ _ = M.empty
-
--- | All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . SrcLoc.sortLocated $ decls
- where
- decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs (DocD noExtField) class_
- defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
- sigs = mkDecls tcdSigs (SigD noExtField) class_
- ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
-
-
--- | The top-level declarations of a module that we care about,
--- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-topDecls =
- filterClasses . filterDecls . collectDocs . SrcLoc.sortLocated . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup GhcRn -> FixMap
@@ -548,86 +446,6 @@ mkFixMap group_ =
L _ n <- ns ]
--- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-ungroup group_ =
- mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
- mkDecls hs_derivds (DerivD noExtField) group_ ++
- mkDecls hs_defds (DefD noExtField) group_ ++
- mkDecls hs_fords (ForD noExtField) group_ ++
- mkDecls hs_docs (DocD noExtField) group_ ++
- mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
- mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
- mkDecls (valbinds . hs_valds) (ValD noExtField) group_
- where
- typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
- typesigs _ = error "expected ValBindsOut"
-
- valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds
- valbinds _ = error "expected ValBindsOut"
-
-
--- | Take a field of declarations from a data structure and create HsDecls
--- using the given constructor
-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
-
---------------------------------------------------------------------------------
--- Filtering of declarations
---
--- We filter out declarations that we don't intend to handle later.
---------------------------------------------------------------------------------
-
-
--- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unL . fst)
- where
- isHandled (ForD _ (ForeignImport {})) = True
- isHandled (TyClD {}) = True
- isHandled (InstD {}) = True
- isHandled (DerivD {}) = True
- isHandled (SigD _ d) = isUserLSig (reL d)
- isHandled (ValD {}) = True
- -- we keep doc declarations to be able to get at named docs
- isHandled (DocD {}) = True
- isHandled _ = False
-
--- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
- | x@(L loc d, doc) <- decls ]
- where
- filterClass (TyClD x c) =
- TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
- filterClass _ = error "expected TyClD"
-
-
---------------------------------------------------------------------------------
--- Collect docs
---
--- To be able to attach the right Haddock comment to the right declaration,
--- we sort the declarations by their SrcLoc and "collect" the docs for each
--- declaration.
---------------------------------------------------------------------------------
-
-
--- | Collect docs and attach them to the right declarations.
-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
-collectDocs = go Nothing []
- where
- go Nothing _ [] = []
- go (Just prev) docs [] = finished prev docs []
- go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
- | Nothing <- prev = go Nothing (str:docs) ds
- | Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
- go Nothing docs (d:ds) = go (Just d) docs ds
- go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
-
- finished decl docs rest = (decl, reverse docs) : rest
-
-
-- | Build the list of items that will become the documentation, from the
-- export list. At this point, the list of ExportItems is in terms of
-- original names.
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 80b84e87..27bad4b9 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -31,6 +31,7 @@ import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)
+import GHC.HsToCore.Docs
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 05:54:30 +0000