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.hs151
1 files changed, 87 insertions, 64 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 9ef3d1b1..c41946f5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -21,6 +21,9 @@ import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
+import Haddock.Backends.Hyperlinker.Types
+import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
+import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
import qualified Data.Map as M
import Data.Map (Map)
@@ -45,7 +48,9 @@ import Bag
import RdrName
import TcRnTypes
import FastString (concatFS)
+import BasicTypes ( StringLiteral(..) )
import qualified Outputable as O
+import HsDecls ( gadtDeclDetails,getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
@@ -122,6 +127,8 @@ createInterface tm flags modMap instIfaceMap = do
mkAliasMap dflags $ tm_renamed_source tm
modWarn = moduleWarning dflags gre warnings
+ tokenizedSrc <- mkMaybeTokenizedSrc flags tm
+
return $! Interface {
ifaceMod = mdl
, ifaceOrigFilename = msHsFilePath ms
@@ -145,6 +152,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceFamInstances = fam_instances
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
+ , ifaceTokenizedSrc = tokenizedSrc
}
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -157,21 +165,21 @@ mkAliasMap dflags mRenamedSource =
alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
- (fmap Module.fsToPackageKey $
- ideclPkgQual impDecl)
+ (fmap Module.fsToUnitId $
+ fmap sl_fs $ ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
-- similar to GHC.lookupModule
lookupModuleDyn ::
- DynFlags -> Maybe PackageKey -> ModuleName -> Module
+ DynFlags -> Maybe UnitId -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
case Packages.lookupModuleInAllPackages dflags mdlName of
(m,_):_ -> m
- [] -> Module.mkModule Module.mainPackageKey mdlName
+ [] -> Module.mkModule Module.mainUnitId mdlName
-------------------------------------------------------------------------------
@@ -194,8 +202,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
parseWarning dflags gre w = force $ case w of
- DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg)
- WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg)
+ DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)
+ WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg)
where
format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
. processDocString dflags gre $ HsDocString xs
@@ -328,30 +336,30 @@ subordinates instMap decl = case decl of
classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
+ dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields
where
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
- | c <- cons, cname <- con_names c ]
- fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
- | RecCon flds <- map con_details cons
+ | c <- cons, cname <- getConNames c ]
+ fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
+ | RecCon flds <- map getConDetails cons
, L _ (ConDeclField ns _ doc) <- (unLoc flds)
- , n <- ns ]
+ , L _ n <- ns ]
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
typeDocs d =
let docs = go 0 in
case d of
- SigD (TypeSig _ ty _) -> docs (unLoc ty)
- SigD (PatSynSig _ _ req prov ty) ->
- let allTys = ty : concat [ unLoc req, unLoc prov ]
- in F.foldMap (docs . unLoc) allTys
- ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
+ SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
+ SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
+ ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty))
TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
_ -> M.empty
where
- go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty)
+ go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+ go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
go n (HsFunTy (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
@@ -394,7 +402,7 @@ ungroup group_ =
mkDecls (typesigs . hs_valds) SigD group_ ++
mkDecls (valbinds . hs_valds) ValD group_
where
- typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
+ typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
typesigs _ = error "expected ValBindsOut"
valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
@@ -426,7 +434,7 @@ filterDecls = filter (isHandled . unL . fst)
isHandled (ForD (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
- isHandled (SigD d) = isVanillaLSig (reL d)
+ isHandled (SigD d) = isUserLSig (reL d)
isHandled (ValD _) = True
-- we keep doc declarations to be able to get at named docs
isHandled (DocD _) = True
@@ -439,7 +447,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
filterClass (TyClD c) =
- TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }
+ TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -498,7 +506,7 @@ mkExportItems
lookupExport (IEVar (L _ x)) = declWith x
lookupExport (IEThingAbs (L _ t)) = declWith t
lookupExport (IEThingAll (L _ t)) = declWith t
- lookupExport (IEThingWith (L _ t) _) = declWith t
+ lookupExport (IEThingWith (L _ t) _ _ _) = declWith t
lookupExport (IEModuleContents (L _ m)) =
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
lookupExport (IEGroup lev docStr) = return $
@@ -517,7 +525,7 @@ mkExportItems
case findDecl t of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
- export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
+ export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
@@ -553,7 +561,7 @@ mkExportItems
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
return [ mkExportDecl t
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
@@ -620,13 +628,19 @@ hiDecl dflags t = do
O.text "-- Please report this on Haddock issue tracker!"
bugWarn = O.showSDoc dflags . warnLine
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc splice fixity = do
+-- | This function is called for top-level bindings without type signatures.
+-- It gets the type signature from GHC and that means it's not going to
+-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
+-- declaration and use it instead - 'nLoc' here.
+hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+ -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl decl doc [] [] fixities splice)
+ Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice)
where
+ fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
fixities = case fixity of
Just f -> [(name, f)]
Nothing -> []
@@ -689,8 +703,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
- m = mkModule packageKey expMod
- packageKey = modulePackageKey thisMod
+ m = mkModule unitId expMod
+ unitId = moduleUnitId thisMod
-- Note [1]:
@@ -724,8 +738,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
expandSig = foldr f []
where
f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
- f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names
- f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names
f x xs = x : xs
mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
@@ -737,7 +751,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
+ fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap)
| otherwise = return Nothing
mkExportItem decl@(L l (InstD d))
| Just name <- M.lookup (getInstLoc d) instMap =
@@ -745,7 +759,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . 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
@@ -769,64 +783,49 @@ extractDecl name mdl decl
case unLoc decl of
TyClD d@ClassDecl {} ->
let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
- isVanillaLSig sig ] -- TODO: document fixity
+ isTypeLSig sig ] -- TODO: document fixity
in case matches of
- [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
- L pos sig = extractClassDecl n tyvar_names s0
+ [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
+ L pos sig = addClassContext n tyvar_names s0
in L pos (SigD sig)
_ -> error "internal: extractDecl (ClassDecl)"
TyClD d@DataDecl {} ->
- let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
- in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+ let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
+ in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
- , dfid_pats = HsWB { hswb_cts = tys }
+ , dfid_pats = HsIB { hsib_body = tys }
, dfid_defn = defn }) ->
SigD <$> extractRecSel name mdl n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d | L _ d <- insts
- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+ -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+ , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , n == name
+ , selectorFieldOcc n == name
]
in case matches of
[d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
- where
- getTyVars = hsLTyVarLocNames . tyClDeclTyVars
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc = noLoc . HsTyVar . unLoc
-
-
-extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of
- L _ (HsForAllTy expl _ tvs (L _ preds) ty) ->
- L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) [])
- _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) [])
- where
- lctxt = noLoc . ctxt
- ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
-extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
-
extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
- case con_details con of
- RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
- L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+ case getConDetails con of
+ RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
_ -> extractRecSel nm mdl t tvs rest
where
- matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
+ matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+ , L l n <- ns, selectorFieldOcc n == nm ]
data_ty
- | ResTyGADT _ ty <- con_res con = ty
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
-
+ -- | 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
-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
@@ -855,6 +854,30 @@ seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
+mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule
+ -> ErrMsgGhc (Maybe [RichToken])
+mkMaybeTokenizedSrc flags tm
+ | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
+ Just src -> do
+ tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src
+ return $ Just tokens
+ Nothing -> do
+ liftErrMsg . tell . pure $ concat
+ [ "Warning: Cannot hyperlink module \""
+ , moduleNameString . ms_mod_name $ summary
+ , "\" because renamed source is not available"
+ ]
+ return Nothing
+ | otherwise = return Nothing
+ where
+ summary = pm_mod_summary . tm_parsed_module $ tm
+
+mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
+mkTokenizedSrc ms src =
+ Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc
+ where
+ rawSrc = readFile $ msHsFilePath ms
+
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 14:37:24 +0000