From 3fb2208eddb9836d11655e44ad35adf158d2aa23 Mon Sep 17 00:00:00 2001 From: davve Date: Sat, 12 Aug 2006 17:15:34 +0000 Subject: Perfect rendering of Test.hs --- src/HaddockHtml.hs | 3 +- src/HaddockRename.hs | 2 +- src/Html.hs | 4 +-- src/Main.hs | 78 ++++++++++++++++++++++++++++++++++------------------ 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 -- cgit v1.2.3