aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/Create.hs126
1 files changed, 61 insertions, 65 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 874037d7..4b82f4c0 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -75,14 +75,14 @@ createInterface ghcMod flags modMap instIfaceMap = do
opts exports ignoreExps instances instIfaceMap
let visibleNames = mkVisibleNames exportItems opts
-
+
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
- let
+ let
prunedExportItems
| OptPrune `elem` opts = pruneExportItems exportItems
| otherwise = exportItems
-
+
return Interface {
ifaceMod = mdl,
ifaceOrigFilename = ghcFilename ghcMod,
@@ -95,7 +95,7 @@ createInterface ghcMod flags modMap instIfaceMap = do
ifaceExportItems = prunedExportItems,
ifaceRnExportItems = [],
ifaceExports = exportedNames,
- ifaceVisibleExports = visibleNames,
+ ifaceVisibleExports = visibleNames,
ifaceDeclMap = declMap,
ifaceSubMap = mkSubMap declMap exportedNames,
ifaceInstances = instances,
@@ -112,12 +112,12 @@ createInterface ghcMod flags modMap instIfaceMap = do
mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
mkDocOpts mbOpts flags mdl = do
- opts <- case mbOpts of
+ opts <- case mbOpts of
Just opts -> case words $ replace ',' ' ' opts of
[] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
xs -> liftM catMaybes (mapM parseOption xs)
Nothing -> return []
- if Flag_HideModule (moduleString mdl) `elem` flags
+ if Flag_HideModule (moduleString mdl) `elem` flags
then return $ OptHide : opts
else return opts
@@ -161,7 +161,7 @@ mkSubMap declMap exports =
-- Make a map from names to 'DeclInfo's. Exclude declarations that don't have
-- names (e.g. instances and stand-alone documentation comments). Include
--- subordinate names, but map them to their parent declarations.
+-- subordinate names, but map them to their parent declarations.
mkDeclMap :: [DeclInfo] -> Map Name DeclInfo
mkDeclMap decls = Map.fromList . concat $
[ (declName d, (parent, doc, subs)) : subDecls
@@ -218,7 +218,7 @@ classDataSubs decl
classSubs = [ (declName d, doc, fnArgsDoc)
| (L _ d, doc) <- classDecls decl
, let fnArgsDoc = getDeclFnArgDocs d ]
- dataSubs = constrs ++ fields
+ dataSubs = constrs ++ fields
where
cons = map unL $ tcdCons decl
-- should we use the type-signature of the constructor
@@ -233,14 +233,14 @@ classDataSubs decl
-- All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
+-- source location, with documentation attached if it exists.
classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)]
classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass
declsFromClass :: TyClDecl a -> [Located (HsDecl a)]
declsFromClass class_ = docs ++ defs ++ sigs ++ ats
- where
+ where
docs = mkDecls tcdDocs DocD class_
defs = mkDecls (bagToList . tcdMeths) ValD class_
sigs = mkDecls tcdSigs SigD class_
@@ -255,9 +255,9 @@ declName (SigD sig) = fromJust $ sigNameNoLoc sig
declName _ = error "unexpected argument to declName"
--- | The top-level declarations of a module that we care about,
+-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]
+topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup
@@ -268,7 +268,7 @@ filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d))
-- | Take all declarations except pragmas, infix decls, rules and value
-- bindings from an 'HsGroup'.
declsFromGroup :: HsGroup Name -> [Decl]
-declsFromGroup group_ =
+declsFromGroup group_ =
mkDecls hs_tyclds TyClD group_ ++
mkDecls hs_derivds DerivD group_ ++
mkDecls hs_defds DefD group_ ++
@@ -336,11 +336,11 @@ filterDecls decls = filter (isHandled . unL . fst) decls
-- | Go through all class declarations and filter their sub-declarations
filterClasses :: [(Decl, doc)] -> [(Decl, doc)]
-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
+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 isVanillaLSig $ tcdSigs c }
+ TyClD $ c { tcdSigs = filter isVanillaLSig $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -348,7 +348,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
-- 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
+-- we sort the declarations by their SrcLoc and "collect" the docs for each
-- declaration.
--------------------------------------------------------------------------------
@@ -423,14 +423,14 @@ finishedDoc d doc rest = (d, docStringToList doc) : rest
-- might be useful when creating the export items for other modules.
mkExportItems
:: ModuleMap
- -> Module -- this module
+ -> Module -- this module
-> GlobalRdrEnv
- -> [Name] -- exported names (orig)
+ -> [Name] -- exported names (orig)
-> [DeclInfo]
- -> Map Name DeclInfo -- maps local names to declarations
+ -> Map Name DeclInfo -- maps local names to declarations
-> [DocOption]
-> Maybe [IE Name]
- -> Bool -- --ignore-all-exports flag
+ -> Bool -- --ignore-all-exports flag
-> [Instance]
-> InstIfaceMap
-> ErrMsgGhc [ExportItem Name]
@@ -442,21 +442,13 @@ mkExportItems modMap this_mod gre exported_names decls declMap
| otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps)
where
--- creating export items for intsances (unfinished experiment)
--- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ]
everything_local_exported = -- everything exported
liftErrMsg $ fullContentsOfThisModule gre decls
-
+
lookupExport (IEVar x) = declWith x
lookupExport (IEThingAbs t) = declWith t
- -- | Just fam <- Map.lookup t famMap = absFam fam
- -- | otherwise = declWith t
- -- where
- -- absFam (Just (famDecl, doc), instances) = return $ [ ExportDecl famDecl doc [] ] ++ matchingInsts t
- -- absFam (Nothing, instances) =
-
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) = fullContentsOf m
@@ -472,11 +464,13 @@ mkExportItems modMap this_mod gre exported_names decls declMap
ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
(\doc -> return [ ExportDoc doc ]))
+
ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b]
ifDoc parse finish = do
mbDoc <- parse
case mbDoc of Nothing -> return []; Just doc -> finish doc
+
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
@@ -612,6 +606,7 @@ mkExportItems modMap this_mod gre exported_names decls declMap
) subs
)]
+
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
mkExportDecl n (decl, doc, subs) = decl'
where
@@ -620,36 +615,37 @@ mkExportItems modMap this_mod gre exported_names decls declMap
subs' = filter ((`elem` exported_names) . fst) subs
sub_names = map fst subs'
+
isExported = (`elem` exported_names)
+
fullContentsOf modname
- | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
- | otherwise =
- case Map.lookup m modMap of
- Just iface
- | OptHide `elem` ifaceOptions iface
- -> return (ifaceExportItems iface)
- | otherwise -> return [ ExportModule m ]
-
- Nothing -> -- we have to try to find it in the installed interfaces
- -- (external packages)
- case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of
- Just iface -> return [ ExportModule (instMod iface) ]
- Nothing -> do
- liftErrMsg $
- tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty modname]
- return []
+ | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
+ | otherwise =
+ case Map.lookup m modMap of
+ Just iface
+ | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
+ | otherwise -> return [ ExportModule m ]
+
+ Nothing -> -- we have to try to find it in the installed interfaces
+ -- (external packages)
+ case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of
+ Just iface -> return [ ExportModule (instMod iface) ]
+ Nothing -> do
+ liftErrMsg $
+ tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty modname]
+ return []
where
m = mkModule packageId modname
packageId = modulePackageId this_mod
-
+
findDecl :: Name -> Maybe DeclInfo
- findDecl n
+ findDecl n
| m == this_mod = Map.lookup n declMap
| otherwise = case Map.lookup m modMap of
- Just iface -> Map.lookup n (ifaceDeclMap iface)
+ Just iface -> Map.lookup n (ifaceDeclMap iface)
Nothing -> Nothing
where
m = nameModule n
@@ -686,23 +682,22 @@ fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
--- cases we have to extract the required declaration (and somehow cobble
+-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...)
extractDecl :: Name -> Module -> Decl -> Decl
extractDecl name mdl decl
| Just n <- getMainDeclBinder (unLoc decl), n == name = decl
- | otherwise =
+ | otherwise =
case unLoc decl of
- TyClD d | isClassDecl d ->
+ TyClD d | isClassDecl d ->
let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name,
isVanillaLSig sig ] -- TODO: document fixity
--- let assocMathes = [ tyDecl | at <- tcdATs d, ]
- in case matches of
+ in case matches of
[s0] -> let (n, tyvar_names) = name_and_tyvars d
L pos sig = extractClassDecl n tyvar_names s0
in L pos (SigD sig)
- _ -> error "internal: extractDecl"
- TyClD d | isDataDecl d ->
+ _ -> error "internal: extractDecl"
+ TyClD d | isDataDecl d ->
let (n, tyvar_names) = name_and_tyvars d
L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)
in L pos (SigD sig)
@@ -717,12 +712,12 @@ 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 _ (HsForAllTy expl tvs (L _ preds) ty) ->
L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
_ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
where
lctxt = noLoc . ctxt
- ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds
+ ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds
extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
@@ -732,19 +727,20 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
- RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+ RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
- where
- matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
+ where
+ matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
-- Pruning
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems items = filter hasDoc items
- where hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
- hasDoc _ = True
+ where
+ hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
+ hasDoc _ = True
mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
@@ -756,7 +752,7 @@ mkVisibleNames exports opts
case getMainDeclBinder $ unL $ expItemDecl e of
Just n -> n : subs
Nothing -> subs
- where subs = map fst (expItemSubDocs e)
+ where subs = map fst (expItemSubDocs e)
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -769,7 +765,7 @@ findNamedDoc name decls = search decls
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search ((DocD (DocCommentNamed name' doc)):rest)
+ search ((DocD (DocCommentNamed name' doc)):rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 01:51:38 +0000