diff options
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 41 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 1 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 1 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 184 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 1 |
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 = |