aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaddockHtml.hs3
-rw-r--r--src/HaddockRename.hs2
-rw-r--r--src/Html.hs4
-rw-r--r--src/Main.hs78
4 files changed, 57 insertions, 30 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 3e7debaa..e0c7121b 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -812,7 +812,8 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
s8 </> methHdr </>
tda [theclass "body"] << vanillaTable << (
abovesSep s8 [ ppSig summary links loc mbDoc sig
- | L _ sig@(TypeSig (L _ (NoLink n)) t) <- lsigs, let mbDoc = Map.lookup n docMap ]
+ | L _ sig@(TypeSig n _) <- lsigs,
+ let mbDoc = Map.lookup (orig n) docMap ]
)
instId = collapseId nm
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index fa3df77c..8f7698ac 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -99,7 +99,7 @@ renameDoc doc = case doc of
lkp <- getLookupRn
case [ n | (True, n) <- map lkp ids ] of
ids'@(_:_) -> return (DocIdentifier ids')
- [] -> return (DocIdentifier (map Link ids))
+ [] -> return (DocIdentifier (map NoLink ids))
DocModule str -> return (DocModule str)
DocEmphasis doc -> do
doc' <- renameDoc doc
diff --git a/src/Html.hs b/src/Html.hs
index ae14c9ae..530df829 100644
--- a/src/Html.hs
+++ b/src/Html.hs
@@ -81,10 +81,10 @@ class ADDATTRS a where
(!) :: a -> [HtmlAttr] -> a
instance (ADDATTRS b) => ADDATTRS (a -> b) where
- fn ! attr = \ arg -> fn arg ! attr
+ (!) fn attr = \ arg -> fn arg ! attr
instance ADDATTRS Html where
- (Html htmls) ! attr = Html (map addAttrs htmls)
+ (!) (Html htmls) attr = Html (map addAttrs htmls)
where
addAttrs html =
case html of
diff --git a/src/Main.hs b/src/Main.hs
index e3ba007b..856b5bd0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -278,16 +278,16 @@ run flags files = do
let (haddockModules'', messages') = runWriter $ mapM (renameModule env) haddockModules'
- putStrLn "pass 1 messages:"
+-- putStrLn "pass 1 messages:"
print messages
- putStrLn "pass 1 export items:"
+{- putStrLn "pass 1 export items:"
printSDoc (ppr (map hmod_export_items haddockModules')) defaultUserStyle
putStrLn "pass 2 env:"
printSDoc (ppr (Map.toList env)) defaultUserStyle
putStrLn "pass 2 export items:"
- printSDoc (ppr (map hmod_rn_export_items haddockModules'')) defaultUserStyle
+ printSDoc (ppr (map hmod_rn_export_items haddockModules'')) defaultUserStyle -}
mapM_ putStrLn messages'
let visibleModules = [ m | m <- haddockModules'', OptHide `notElem` (hmod_options m) ]
@@ -401,11 +401,22 @@ instance Outputable (DocEntity Name) where
ppr (DocEntity d) = ppr d
ppr (DeclEntity name) = ppr name
+instance Show Name where
+ show name = show (ppr name defaultUserStyle)
+
+instance Show a => Show (DocDecl a) where
+ show (DocCommentNext doc) = "next" ++ show doc
+ show (DocCommentPrev doc) = "prev" ++ show doc
+ show _ = "other"
+
type FullyCheckedModule = (ParsedSource,
RenamedSource,
TypecheckedSource,
ModuleInfo)
+printEntity (DocEntity doc) = show doc
+printEntity (DeclEntity name) = show $ ppr name defaultUserStyle
+
pass1 :: [(Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2
pass1 modules flags package = worker modules (Map.empty) flags
where
@@ -419,8 +430,9 @@ pass1 modules flags package = worker modules (Map.empty) flags
opts <- mk_doc_opts mb_doc_opts
let (group, _, mb_exports, mbModDoc, haddockModInfo) = renamed_source
- entities = nubBy sameName (hs_docs group)
- exports = fmap (map unLoc) mb_exports
+
+ entities = (reverse . nubBy sameName . hs_docs) group
+ exports = fmap (reverse . map unLoc) mb_exports
-- lots of names
exportedNames = modInfoExports moduleInfo
@@ -431,12 +443,13 @@ pass1 modules flags package = worker modules (Map.empty) flags
scopeNames = fromJust $ modInfoTopLevelScope moduleInfo
subMap = mk_sub_map_from_group group
-
+
+ -- tell (map printEntity entities)
theseVisibleNames <- visibleNames mod moduleMap localNames scopeNames subMap exports opts
let exportedDeclMap = mkDeclMap exportedNames group
localDeclMap = mkDeclMap theseEntityNames group
- docMap = mkDocMap group
+ docMap = mkDocMap group
ignoreAllExports = Flag_IgnoreAllExports `elem` flags
@@ -494,13 +507,26 @@ sameName (DocEntity _) _ = False
sameName (DeclEntity _) (DocEntity _) = False
sameName (DeclEntity a) (DeclEntity b) = a == b
-mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)
-mkDocMap group = Map.fromList $
- collectDocs (hs_docs group) ++ collectDocsFromClassMeths (getClasses group)
+-- This map includes everything that can be exported separately,
+-- that means: top declarations, class methods and record selectors
+-- TODO: merge this with mkDeclMap and the extractXXX functions
+mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)
+mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs)
where
- getClasses group = filter isClassDecl (map unLoc (hs_tyclds group))
- collectDocsFromClassMeths classes = concatMap (collectDocs . tcdDocs) classes
-
+ tyclds = map unLoc (hs_tyclds group)
+ classes = filter isClassDecl tyclds
+ datadecls = filter isDataDecl tyclds
+ constrs = [ con | d <- datadecls, L _ con <- tcdCons d ]
+ fields = concat [ fields | RecCon fields <- map con_details constrs]
+
+ topDeclDocs = collectDocs (reverse (hs_docs group))
+
+ classMethDocs
+ = concatMap (collectDocs . tcdDocs) classes
+
+ recordFieldDocs = [ (unLoc lname, doc) |
+ HsRecField lname _ (Just (L _ doc)) <- fields ]
+
collectDocs :: [DocEntity Name] -> [(Name, HsDoc Name)]
collectDocs entities = collect Nothing DocEmpty entities
@@ -511,19 +537,19 @@ collect d doc_so_far [] =
Just d0 -> finishedDoc d0 doc_so_far []
collect d doc_so_far (e:es) =
- case e of
- DocEntity (DocCommentNext str) ->
- case d of
- Nothing -> collect d (docAppend doc_so_far str) es
- Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
-
- DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es
-
- _other ->
- case d of
- Nothing -> collect (Just e) doc_so_far es
- Just d0 -> finishedDoc d0 doc_so_far
- (collect (Just e) DocEmpty es)
+ case e of
+ DocEntity (DocCommentNext str) ->
+ case d of
+ Nothing -> collect d (docAppend doc_so_far str) es
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+
+ DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es
+
+ _ -> case d of
+ Nothing -> collect (Just e) doc_so_far es
+ Just d0
+ | sameName d0 e -> collect d doc_so_far es
+ | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
finishedDoc :: DocEntity Name -> HsDoc Name -> [(Name, HsDoc Name)] -> [(Name, HsDoc Name)]
finishedDoc d DocEmpty rest = rest
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:29:49 +0000