aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/Create.hs
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2020-06-24 13:53:39 -0400
committerGitHub <noreply@github.com>2020-06-24 13:53:39 -0400
commitcaae45aa98a7ca5182bb52aeafc22fd91e4ceb59 (patch)
tree60fe9c1db01bf65bad43744b6164a7b5cbd38f9c /haddock-api/src/Haddock/Interface/Create.hs
parentb32845d1a4fe5ea6376f0dec58422520daf06b2e (diff)
parent45add0d8a39172d17e822b762508685d7b433639 (diff)
Merge pull request #1204 from wz1000/wip/haddock-hstocore
Use functions exported from GHC.HsToCore.Docs
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs184
1 files changed, 1 insertions, 183 deletions
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.