From 11385cf01f0d852782444ebfeb4e5092c174c6f8 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Jan 2012 21:28:14 +0100 Subject: Make sure that generated xhtml is valid (close #186) Thanks to Phyx. --- html/frames.html | 8 +++++--- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Layout.hs | 9 +++++++++ src/Haddock/Backends/Xhtml/Utils.hs | 11 +---------- tests/html-tests/tests/A.html.ref | 2 +- tests/html-tests/tests/B.html.ref | 2 +- tests/html-tests/tests/Bug1.html.ref | 2 +- tests/html-tests/tests/Bug2.html.ref | 2 +- tests/html-tests/tests/Bug3.html.ref | 2 +- tests/html-tests/tests/Bug4.html.ref | 2 +- tests/html-tests/tests/Bug6.html.ref | 2 +- tests/html-tests/tests/Bug7.html.ref | 2 +- tests/html-tests/tests/Bug8.html.ref | 2 +- tests/html-tests/tests/Bugs.html.ref | 2 +- tests/html-tests/tests/CrossPackageDocs.html.ref | 2 +- tests/html-tests/tests/Examples.html.ref | 2 +- tests/html-tests/tests/FunArgs.html.ref | 2 +- tests/html-tests/tests/GADTRecords.html.ref | 2 +- tests/html-tests/tests/Hash.html.ref | 2 +- tests/html-tests/tests/NamedDoc.html.ref | 2 +- tests/html-tests/tests/NoLayout.html.ref | 2 +- tests/html-tests/tests/NonGreedy.html.ref | 2 +- tests/html-tests/tests/QuasiExpr.html.ref | 2 +- tests/html-tests/tests/QuasiQuote.html.ref | 2 +- tests/html-tests/tests/TH.html.ref | 2 +- tests/html-tests/tests/TH2.html.ref | 2 +- tests/html-tests/tests/Test.html.ref | 2 +- tests/html-tests/tests/Ticket112.html.ref | 2 +- tests/html-tests/tests/Ticket61.html.ref | 2 +- tests/html-tests/tests/Ticket75.html.ref | 2 +- tests/html-tests/tests/TypeFamilies.html.ref | 2 +- tests/html-tests/tests/TypeOperators.html.ref | 2 +- tests/html-tests/tests/Unicode.html.ref | 2 +- tests/html-tests/tests/Visible.html.ref | 2 +- 34 files changed, 46 insertions(+), 44 deletions(-) diff --git a/html/frames.html b/html/frames.html index 30ce1fa5..1b4e38d4 100644 --- a/html/frames.html +++ b/html/frames.html @@ -3,6 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"> + + - - + + - + diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 52bde5b6..c8998f3e 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -175,7 +175,7 @@ bodyHtml doctitle iface contentsButton maybe_contents_url, indexButton maybe_index_url]) ! [theclass "links", identifier "page-menu"], - nonEmpty sectionName << doctitle + nonEmptySectionName << doctitle ], divContent << pageContent, divFooter << paragraph << ( diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index bdd5ac78..da17552c 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -18,6 +18,7 @@ module Haddock.Backends.Xhtml.Layout ( divIndex, divAlphabet, divModuleList, sectionName, + nonEmptySectionName, shortDeclList, shortSubDecls, @@ -66,6 +67,14 @@ sectionName :: Html -> Html sectionName = paragraph ! [theclass "caption"] +-- | Make an element that always has at least something (a non-breaking space) +-- If it would have otherwise been empty, then give it the class ".empty" +nonEmptySectionName :: Html -> Html +nonEmptySectionName c + | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml + | otherwise = paragraph ! [theclass "caption"] $ c + + divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynposis, divInterface, divIndex, divAlphabet, divModuleList diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index 7ba6d5f4..c020c64d 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Utils ( spliceURL, groupId, - (<+>), char, nonEmpty, + (<+>), char, keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, @@ -119,15 +119,6 @@ char :: Char -> Html char c = toHtml [c] --- | Make an element that always has at least something (a non-breaking space) --- If it would have otherwise been empty, then give it the class ".empty" -nonEmpty :: (Html -> Html) -> Html -> Html -nonEmpty el content_ = - if isNoHtml content_ - then el ! [theclass "empty"] << spaceHtml - else el << content_ - - quote :: Html -> Html quote h = char '`' +++ h +++ '`' diff --git a/tests/html-tests/tests/A.html.ref b/tests/html-tests/tests/A.html.ref index 38a39479..d5e6dcc0 100644 --- a/tests/html-tests/tests/A.html.ref +++ b/tests/html-tests/tests/A.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Index

 

Date: Wed, 25 Jan 2012 00:44:15 +0100 Subject: Fix bug introduced in my recent refactoring. --- src/Haddock/Interface/Create.hs | 34 ++++++++------- tests/html-tests/tests/A.hs | 9 ++++ tests/html-tests/tests/A.html.ref | 88 +++++++++++++++++++++++++++++++++++++++ tests/html-tests/tests/B.hs | 4 +- tests/html-tests/tests/B.html.ref | 57 +++++++++++++++++++++++++ 5 files changed, 174 insertions(+), 18 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 580aaa83..0a0c0e2d 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -433,13 +433,12 @@ mkExportItems declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = - let (doc, subs) = exportDecl t docMap argMap subMap in case findDecl t of - [L _ (ValD _)] -> do + ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem t doc return [export] - ds | decl : _ <- filter (not . isValD . unLoc) ds -> + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of _ @@ -461,7 +460,7 @@ mkExportItems return [] -- normal case - | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ] + | otherwise -> return [ mkExportDecl t newDecl docs_ ] where -- Since a single signature might refer to many names, we -- need to filter the ones that are actually exported. This @@ -475,7 +474,7 @@ mkExportItems _ -> decl -- Declaration from another package - [] -> do + ([], _) -> do mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -489,7 +488,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> do - return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -506,13 +505,15 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> [LHsDecl Name] - findDecl name - | mdl == thisMod = maybe [] id (M.lookup name declMap) - | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface)) - | otherwise = [] + findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl n + | m == thisMod, Just ds <- M.lookup n declMap = + (ds, lookupDocs n docMap argMap subMap) + | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + | otherwise = ([], (noDocForDecl, [])) where - mdl = nameModule name + m = nameModule n hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) @@ -533,8 +534,9 @@ hiValExportItem name doc = do Just decl -> return (ExportDecl decl doc [] []) -exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -exportDecl name docMap argMap subMap = +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs name docMap argMap subMap = let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in let doc = (M.lookup name docMap, lookupArgMap name) in let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in @@ -616,12 +618,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = exportDecl name docMap argMap subMap in + let (doc, _) = lookupDocs name docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = exportDecl name docMap argMap subMap in + let (doc, subs) = lookupDocs name docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing diff --git a/tests/html-tests/tests/A.hs b/tests/html-tests/tests/A.hs index ac8fad49..606b0865 100644 --- a/tests/html-tests/tests/A.hs +++ b/tests/html-tests/tests/A.hs @@ -1,8 +1,17 @@ module A where + data A = A other :: Int other = 2 +-- | Doc for test2 test2 :: Bool test2 = False + +-- | Should show up on the page for both modules A and B +data X = X -- ^ Doc for consructor + +-- | Should show up on the page for both modules A and B +reExport :: Int +reExport = 1 diff --git a/tests/html-tests/tests/A.html.ref b/tests/html-tests/tests/A.html.ref index 38a39479..143f8a73 100644 --- a/tests/html-tests/tests/A.html.ref +++ b/tests/html-tests/tests/A.html.ref @@ -41,6 +41,46 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >

A

Synopsis

Documentation

:: Bool

Doc for test2 +

data X

Should show up on the page for both modules A and B +

Constructors

X

Doc for consructor +

reExport :: Int

Should show up on the page for both modules A and B +

:: Int
  • reExport :: Int
  • data X = X

    • reExport :: Int

    Should show up on the page for both modules A and B +

    data X

    Should show up on the page for both modules A and B +

    Constructors

    X

    Doc for consructor +

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Index

     

    Date: Sat, 4 Feb 2012 03:21:12 +0100 Subject: Use mapM_ in accept.hs as well. --- tests/html-tests/accept.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/html-tests/accept.hs b/tests/html-tests/accept.hs index fe1e5422..49da5c5a 100644 --- a/tests/html-tests/accept.hs +++ b/tests/html-tests/accept.hs @@ -13,9 +13,9 @@ main = do contents <- getDirectoryContents (dir "output") if not $ null args then - mapM copy [ "output" file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] + mapM_ copy [ "output" file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] else - mapM copy [ "output" file | file <- contents, ".html" `isSuffixOf` file ] + mapM_ copy [ "output" file | file <- contents, ".html" `isSuffixOf` file ] copy file = do -- cgit v1.2.3 From fbef8bafd21d34f83326f7dd06bb82c563571345 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 03:21:33 +0100 Subject: Remove copy.hs - use accept.hs instead. --- tests/html-tests/copy.hs | 37 ------------------------------------- 1 file changed, 37 deletions(-) delete mode 100644 tests/html-tests/copy.hs diff --git a/tests/html-tests/copy.hs b/tests/html-tests/copy.hs deleted file mode 100644 index 188bfd33..00000000 --- a/tests/html-tests/copy.hs +++ /dev/null @@ -1,37 +0,0 @@ -import System.Cmd -import System.Environment -import System.FilePath -import System.Exit -import System.Directory -import Data.List -import Control.Monad - - -main :: IO () -main = do - args <- getArgs - dir <- getCurrentDirectory - contents <- getDirectoryContents (dir "output") - if not $ null args - then - mapM_ copy [ "output" file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] - else - mapM_ copy [ "output" file | file <- contents, ".html" `isSuffixOf` file ] - - -copy file = do - let new = "tests" takeFileName file <.> ".ref" - print file - print new - contents <- readFile file - writeFile new (stripLinks contents) - - -stripLinks str = - let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs -- cgit v1.2.3 From 46a65020cdbb8aee274e5ab3db68f51639e8d1b2 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 03:39:38 +0100 Subject: Use <> instead of mappend. --- src/Haddock/Interface/Create.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 06d97265..cac3eac2 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -142,7 +142,7 @@ createInterface tm flags modMap instIfaceMap = do addWarnings :: Warnings -> GlobalRdrEnv -> [Name] -> DocMap Name -> DocMap Name addWarnings NoWarnings _ _ dm = dm addWarnings (WarnAll _) _ _ dm = dm -addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip mappend) dm wm +addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip (<>)) dm wm where wm = M.fromList [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ @@ -154,7 +154,7 @@ addModuleWarning ws = case ws of NoWarnings -> id WarnSome _ -> id - WarnAll w -> let d = warnToDoc w in Just . maybe d (mappend d) + WarnAll w -> let d = warnToDoc w in Just . maybe d (d <>) warnToDoc :: WarningTxt -> Doc id @@ -209,7 +209,7 @@ mkMaps :: DynFlags mkMaps dflags gre instances exports decls = do (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b - f = M.fromListWith mappend . concat + f = M.fromListWith (<>) . concat return (f dm, f am, f sm, f cm) where mappings (ldecl@(L _ decl), docs) = do -- cgit v1.2.3 From b31252e0699a65a8e7d0168f012b58fde50c4b3d Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 03:48:55 +0100 Subject: Remove code for older ghc versions. --- src/Haddock/Backends/Xhtml/Decl.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 930a81bf..9d7865f2 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -717,11 +717,7 @@ ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -#if __GLASGOW_HASKELL__ == 612 -ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -#else ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -#endif ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -- cgit v1.2.3 From ac8e218ba6407fc826fc54e0f1b7ac23c0c6b338 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 15:52:51 +0100 Subject: Clean up some code from last SoC project. --- src/Haddock/Interface/Create.hs | 75 +++++++++++++++++++---------------- src/Haddock/Interface/LexParseRn.hs | 78 ++++++++++++++++++------------------- src/Haddock/Types.hs | 1 - 3 files changed, 78 insertions(+), 76 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index cac3eac2..737547fd 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -28,7 +28,7 @@ import Data.Monoid import Data.Ord import Control.Applicative import Control.Monad -import qualified Data.Traversable as Traversable +import qualified Data.Traversable as T import GHC hiding (flags) import HscTypes @@ -72,7 +72,7 @@ createInterface tm flags modMap instIfaceMap = do | otherwise = opts0 (info, mbDoc) <- do - (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader + (i, d) <- liftErrMsg $ processModuleHeader dflags gre mayDocHeader return (i, addModuleWarning warnings d) let declsWithDocs = topDecls group_ @@ -193,13 +193,16 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- --- Declarations +-- Maps -------------------------------------------------------------------------------- type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) +-- | Create 'Maps' by looping through the declarations. For each declaration, +-- find its names, its subordinates, and its doc strings. Process doc strings +-- into 'Doc's. mkMaps :: DynFlags -> GlobalRdrEnv -> [Instance] @@ -207,38 +210,36 @@ mkMaps :: DynFlags -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps mkMaps dflags gre instances exports decls = do - (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls - let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - return (f dm, f am, f sm, f cm) + (a, b, c, d) <- unzip4 <$> mapM mappings decls + return (f a, f b, f c, f d) where - mappings (ldecl@(L _ decl), docs) = do - doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs - argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $ - lexParseRnHaddockComment dflags NormalHaddockComment gre - + f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + mappings (ldecl, docStrs) = do + let decl = unLoc ldecl + let declDoc strs m = do + doc <- processDocStrings dflags gre strs + m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m + return (doc, m') + (doc, args) <- declDoc docStrs (typeDocs decl) let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ] - - (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do - mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr - subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ - lexParseRnHaddockComment dflags NormalHaddockComment gre - return ((n, mbSubDoc), (n, subFnArgsDoc))) - - let names = case decl of - -- See note [2]. - InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) - _ -> filter (`elem` exports) (getMainDeclBinder decl) - - let subNames = map fst subDocs - dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ] - am = [ (n, argDocs) | n <- names ] ++ subArgMap - sm = [ (n, subNames) | n <- names ] - cm = [ (n, [ldecl]) | n <- names ++ subNames ] + (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs + let ns = names decl + subNs = [ n | (n, _, _) <- subs ] + dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] + am = [ (n, args) | n <- ns ] ++ zip subNs subArgs + sm = [ (n, subNs) | n <- ns ] + cm = [ (n, [ldecl]) | n <- ns ++ subNs ] return (dm, am, sm, cm) + instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] + names :: HsDecl Name -> [Name] + names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2]. + names decl = filter (`elem` exports) (getMainDeclBinder decl) + -- Note [2]: ------------ @@ -249,6 +250,12 @@ mkMaps dflags gre instances exports decls = do -- with InstDecls). +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + + +-- | Get all subordinate declarations inside a declaration, and their docs. subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] subordinates (TyClD decl) | isClassDecl decl = classSubs @@ -446,15 +453,15 @@ mkExportItems lookupExport (IEModuleContents m) = moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps lookupExport (IEGroup lev docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) + ifDoc (processDocString dflags gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) lookupExport (IEDoc docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) + ifDoc (processDocStringParas dflags gre docStr) (\doc -> return [ ExportDoc doc ]) lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | d <- decls ]) (\docStr -> - ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) + ifDoc (processDocStringParas dflags gre docStr) (\doc -> return [ ExportDoc doc ])) @@ -656,10 +663,10 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = f x xs = x : xs mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr + mbDoc <- liftErrMsg $ processDocString dflags gre docStr return $ fmap (ExportGroup lev "") mbDoc mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr + mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr return $ fmap ExportDoc mbDoc mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index ebd2b8fc..61f5d6ac 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn -- Copyright : (c) Isaac Dupree 2009, @@ -9,11 +9,10 @@ -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn - ( HaddockCommentType(..) - , lexParseRnHaddockComment - , lexParseRnHaddockCommentList - , lexParseRnMbHaddockComment - , lexParseRnHaddockModHeader + ( processDocString + , processDocStringParas + , processDocStrings + , processModuleHeader ) where @@ -24,6 +23,7 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Doc import Control.Applicative +import Data.List import Data.Maybe import FastString import GHC @@ -33,62 +33,58 @@ import RdrName import RnEnv -data HaddockCommentType = NormalHaddockComment | DocSectionComment - - -lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockCommentList dflags hty gre docStrs = do - docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs - let docs = catMaybes docMbs - let doc = foldl docAppend DocEmpty docs +processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) +processDocStrings dflags gre strs = do + docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs + let doc = foldl' docAppend DocEmpty docs case doc of DocEmpty -> return Nothing _ -> return (Just doc) -lexParseRnHaddockComment :: DynFlags -> HaddockCommentType -> - GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) +processDocStringParas = process parseParas + + +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) +processDocString = process parseString + +process :: ([LToken] -> Maybe (Doc RdrName)) + -> DynFlags + -> GlobalRdrEnv + -> HsDocString + -> ErrMsgM (Maybe (Doc Name)) +process parse dflags gre (HsDocString fs) = do let str = unpackFS fs - let toks = tokenise dflags str (0,0) -- TODO: real position - let parse = case hty of - NormalHaddockComment -> parseParas - DocSectionComment -> parseString + let toks = tokenise dflags str (0,0) -- TODO: real position case parse toks of Nothing -> do - tell ["doc comment parse failed: "++str] + tell [ "doc comment parse failed: " ++ str ] return Nothing Just doc -> return (Just (rename gre doc)) -lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing -lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d - - --- yes, you always get a HaddockModInfo though it might be empty -lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) -lexParseRnHaddockModHeader dflags gre mbStr = do - (hmi, docn) <- - case mbStr of +processModuleHeader :: DynFlags -> GlobalRdrEnv -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +processModuleHeader dflags gre mayStr = do + (hmi, doc) <- + case mayStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs case parseModuleHeader dflags str of - Left mess -> do - tell ["haddock module header parse failed: " ++ mess] + Left msg -> do + tell ["haddock module header parse failed: " ++ msg] return failure - Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc)) - return (hmi { hmi_safety = safety }, docn) + Right (hmi, doc) -> do + let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi } + doc' = rename gre doc + return (hmi', Just doc') + let safety = Just $ showPpr $ safeHaskell dflags + return (hmi { hmi_safety = safety }, doc) where - safety = Just $ showPpr $ safeHaskell dflags failure = (emptyHaddockModInfo, Nothing) -renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi } - - rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name rename gre = rn where diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index fe4039a7..927fcffb 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -42,7 +42,6 @@ type ArgMap a = Map Name (Map Int (Doc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type SrcMap = Map PackageId FilePath -type GhcDocHdr = Maybe LHsDocString type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources -- cgit v1.2.3 From 12d931b4c3fcd6d8e26cc48b9072b4291efa5cdb Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 21:37:16 +0100 Subject: Mostly hlint-inspired cleanup. --- src/Haddock/Backends/Hoogle.hs | 4 +- src/Haddock/Backends/Xhtml.hs | 6 +-- src/Haddock/Backends/Xhtml/Decl.hs | 65 ++++++++++++++---------------- src/Haddock/Backends/Xhtml/Utils.hs | 4 +- src/Haddock/Interface/Create.hs | 24 +++++------ src/Haddock/Interface/ParseModuleHeader.hs | 6 +-- src/Haddock/Interface/Rename.hs | 20 +++++---- src/Haddock/InterfaceFile.hs | 34 ++++++++-------- src/Haddock/Types.hs | 2 +- src/Haddock/Utils.hs | 9 ++--- 10 files changed, 86 insertions(+), 88 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index cbb5921d..e7a78fc2 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -101,7 +101,7 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr operator :: String -> String -operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")" +operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x @@ -124,7 +124,7 @@ ppExport _ = [] ppSig :: Sig Name -> [String] ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] where - prettyNames = concat . intersperse ", " $ map out names + prettyNames = intercalate ", " $ map out names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index c8998f3e..84468610 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -431,7 +431,7 @@ ppHtmlIndex odir doctitle _maybe_package themes indexLinks nm entries many_entities -> td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml - aboves (map doAnnotatedEntity (zip [1..] many_entities)) + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable doAnnotatedEntity (j,(nm,entries)) @@ -539,7 +539,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual maybe_doc_hdr = case exports of [] -> noHtml - ExportGroup _ _ _ : _ -> noHtml + ExportGroup {} : _ -> noHtml _ -> h1 << "Documentation" bdy = @@ -621,7 +621,7 @@ ppModuleContents qual exports -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] -numberSectionHeadings exports = go 1 exports +numberSectionHeadings = go 1 where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] go _ [] = [] go n (ExportGroup lev _ doc : es) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 9d7865f2..5cdc819c 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -79,7 +79,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> (HsType DocName) -> [SubDecl] + do_args :: Int -> Html -> HsType DocName -> [SubDecl] do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> @@ -99,7 +99,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = (leader <+> ppType unicode qual t, argDoc n, []) : [] + = [(leader <+> ppType unicode qual t, argDoc n, [])] ppTyVars :: [LHsTyVarBndr DocName] -> [Html] @@ -296,12 +296,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual <+> darrow unicode @@ -309,10 +309,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html -pp_hs_context [] _ _ = noHtml -pp_hs_context [p] unicode qual = ppType unicode qual p -pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ------------------------------------------------------------------------------- @@ -326,8 +326,8 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode qual + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html @@ -396,7 +396,7 @@ ppClassDecl summary links instances loc mbDoc subdocs -- there are different subdocs for different names in a single -- type signature? - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" @@ -413,11 +413,8 @@ ppInstances instances baseName unicode qual <+> ppAppNameTypes n ts unicode qual -lookupAnySubdoc :: (Eq name1) => - name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 -lookupAnySubdoc n subdocs = case lookup n subdocs of - Nothing -> noDocForDecl - Just docs -> docs +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n ------------------------------------------------------------------------------- @@ -430,7 +427,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Qualification -> Html ppShortDataDecl summary _links _loc dataDecl unicode qual - | [] <- cons = dataHeader + | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy, (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual @@ -513,7 +510,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of -- (except each field gets its own line in docs, to match -- non-GADT records) RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> - ppForAll forall ltvs lcontext unicode qual <+> char '{', + ppForAll forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) @@ -521,29 +518,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of where doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode qual, + ppForAll forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con mkFunTy a b = noLoc (HsFunTy a b) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Qualification -> Html -ppConstrHdr forall tvs ctxt unicode qual +ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual <+> darrow unicode +++ toHtml " ") where - ppForall = case forall of + ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> noHtml @@ -581,15 +578,15 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode - <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual, + <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. -- 'join' is in Maybe. @@ -651,13 +648,13 @@ tupleParens _ = parenList pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic +pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC +pREC_FUN = 1 :: Int -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = 2 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 3 :: Int -- Used for arg of type applicn: + -- always parenthesise unless atomic maybeParen :: Int -- Precedence of context -> Int -- Precedence of top-level operator @@ -699,7 +696,7 @@ ppForAll expl tvs cxt unicode qual ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html -ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index c020c64d..be1fcb9b 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -44,7 +44,7 @@ import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of @@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url run ('%':'N':rest) = name ++ run rest run ('%':'K':rest) = kind ++ run rest run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = "%" ++ run rest + run ('%':'%':rest) = '%' : run rest run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 737547fd..ed51734d 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -350,7 +350,7 @@ warnAboutFilteredDecls mdl decls = do tell [ "Warning: " ++ modStr ++ ": Instances of type and data " ++ "families are not yet supported. Instances of the following families " - ++ "will be filtered out:\n " ++ concat (intersperse ", " + ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls @@ -359,7 +359,7 @@ warnAboutFilteredDecls mdl decls = do unless (null instances) $ tell [ "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " - ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ] + ++ "These instances are affected:\n" ++ intercalate ", " instances ] -------------------------------------------------------------------------------- @@ -371,7 +371,7 @@ warnAboutFilteredDecls mdl decls = do -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls decls = filter (isHandled . unL . fst) decls +filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True @@ -408,10 +408,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs ((L _ (DocD (DocCommentNext str))):ds) + 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 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) @@ -489,7 +489,7 @@ mkExportItems -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. - | not $ t `elem` declNames, + | t `notElem` declNames, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ @@ -517,7 +517,7 @@ mkExportItems mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] - Just decl -> do + Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package. case M.lookup (nameModule t) instIfaceMap of @@ -526,7 +526,7 @@ mkExportItems ["Warning: Couldn't find .haddock for export " ++ pretty t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] - Just iface -> do + Just iface -> return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -736,9 +736,9 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- Pruning +-- | Keep exprt items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] -pruneExportItems items = filter hasDoc items +pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d hasDoc _ = True @@ -758,12 +758,12 @@ mkVisibleNames exports opts -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) -findNamedDoc name decls = search decls +findNamedDoc name = search where 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 diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index 35533d0d..411b6661 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -137,14 +137,14 @@ parseKey key toParse0 = (spaces1,cs1) = extractLeadingSpaces cs in (c:spaces1,cs1) - | True = ([],s) + | otherwise = ([],s) extractNextLine :: String -> (String,String) extractNextLine [] = ([],[]) extractNextLine (c:cs) | c == '\n' = ([],cs) - | True = + | otherwise = let (line,rest) = extractNextLine cs in @@ -156,5 +156,5 @@ parseKey key toParse0 = extractPrefix _ [] = Nothing extractPrefix (c1:cs1) (c2:cs2) | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | True = Nothing + | otherwise = Nothing diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 582c2ccd..cffe68b8 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -12,19 +12,20 @@ module Haddock.Interface.Rename (renameInterface) where -import Haddock.Types import Haddock.GhcUtils +import Haddock.Types -import GHC hiding (NoLink) -import Name import Bag (emptyBag) import BasicTypes ( IPName(..), ipNameName ) +import GHC hiding (NoLink) +import Name +import Control.Applicative +import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Prelude hiding (mapM) import Data.Traversable (mapM) -import Control.Monad hiding (mapM) +import Prelude hiding (mapM) renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface @@ -93,6 +94,9 @@ instance Monad (GenRnM n) where (>>=) = thenRn return = returnRn +instance Functor (GenRnM n) where + fmap f x = do a <- x; return (f a) + returnRn :: a -> GenRnM n a returnRn a = RnM (const (a,[])) thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b @@ -211,7 +215,7 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind Nothing = return Nothing -renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just +renameMaybeLKind (Just ki) = Just <$> renameLKind ki renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of @@ -241,11 +245,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, (L loc op)) b -> do + HsOpTy a (w, L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, (L loc op')) b') + return (HsOpTy a' (w, L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index e998ffec..970093df 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -22,24 +22,25 @@ module Haddock.InterfaceFile ( import Haddock.Types import Haddock.Utils hiding (out) -import Data.List -import Data.Word +import Control.Monad import Data.Array import Data.IORef +import Data.List import qualified Data.Map as Map import Data.Map (Map) +import Data.Word -import GHC hiding (NoLink) -import Binary import BinIface (getSymtabName, getDictFastString) -import Name -import UniqSupply -import UniqFM -import IfaceEnv -import HscTypes -import GhcMonad (withSession) +import Binary import FastMutInt import FastString +import GHC hiding (NoLink) +import GhcMonad (withSession) +import HscTypes +import IfaceEnv +import Name +import UniqFM +import UniqSupply import Unique @@ -110,8 +111,8 @@ writeInterfaceFile filename iface = do bin_dict_map = dict_map_ref } -- put the main thing - bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab) - (putFastString bin_dict) + let bh = setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) put_ bh iface -- write the symtab pointer at the front of the file @@ -295,12 +296,9 @@ putSymbolTable bh next_off symtab = do getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) getSymbolTable bh namecache = do sz <- get bh - od_names <- sequence (replicate sz (get bh)) - let - arr = listArray (0,sz-1) names - (namecache', names) = - mapAccumR (fromOnDiskName arr) namecache od_names - -- + od_names <- replicateM sz (get bh) + let arr = listArray (0,sz-1) names + (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names return (namecache', arr) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 927fcffb..22d2f6ae 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -430,7 +430,7 @@ throwE str = throw (HaddockException str) -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) } +newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } --instance MonadIO ErrMsgGhc where -- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO --er, implementing GhcMonad involves annoying ExceptionMonad and diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 9865fdf1..3a2f1d28 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -70,7 +70,7 @@ import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) +import System.Exit import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -156,11 +156,11 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail (ConDeclField n _ _) = unLoc n `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] - keep _ | otherwise = Nothing + keep _ = Nothing restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] @@ -286,7 +286,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess +bye s = putStr s >> exitSuccess die :: String -> IO a @@ -319,7 +319,6 @@ escapeStr = escapeURIString isUnreserved -- to avoid depending on the network lib, since doing so gives a -- circular build dependency between haddock and network -- (at least if you want to build network with haddock docs) --- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs escapeURIChar :: (Char -> Bool) -> Char -> String escapeURIChar p c | p c = [c] -- cgit v1.2.3 From eada277a0f492e20d034ec6b8fb08a476232c7c4 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 5 Mar 2012 11:14:20 +0100 Subject: Save/restore global state for static flags when running GHC actions This is necessary if we want to run createInterfaces (from Documentation.Haddock) multiple times in the same process. --- src/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 0a3c9ffc..c0b7df4b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -57,6 +57,7 @@ import Paths_haddock import GHC hiding (flags, verbosity) import Config import DynFlags hiding (flags, verbosity) +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) import Panic (panic, handleGhcException) import Module @@ -290,7 +291,7 @@ dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc libDir flags ghcActs = do +withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do -- TODO: handle warnings? (restFlags, _) <- parseStaticFlags (map noLoc flags) runGhc (Just libDir) $ do @@ -308,6 +309,7 @@ withGhc libDir flags ghcActs = do -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags''' ghcActs dynflags''' + `finally` restoreStaticFlagGlobals savedFlags where parseGhcFlags :: Monad m => DynFlags -> [Located String] -> [String] -> m DynFlags -- cgit v1.2.3 From dec878df8eebb8e831d42db865d59b4e082ec4de Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 01:51:19 +0200 Subject: Disable unicode test. --- tests/html-tests/tests/Unicode.hs | 6 ------ tests/html-tests/tests/Unicode.hs.disabled | 6 ++++++ 2 files changed, 6 insertions(+), 6 deletions(-) delete mode 100644 tests/html-tests/tests/Unicode.hs create mode 100644 tests/html-tests/tests/Unicode.hs.disabled diff --git a/tests/html-tests/tests/Unicode.hs b/tests/html-tests/tests/Unicode.hs deleted file mode 100644 index d5bbf445..00000000 --- a/tests/html-tests/tests/Unicode.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Unicode where - --- | γλώσσα -x :: Int -x = 1 - diff --git a/tests/html-tests/tests/Unicode.hs.disabled b/tests/html-tests/tests/Unicode.hs.disabled new file mode 100644 index 00000000..d5bbf445 --- /dev/null +++ b/tests/html-tests/tests/Unicode.hs.disabled @@ -0,0 +1,6 @@ +module Unicode where + +-- | γλώσσα +x :: Int +x = 1 + -- cgit v1.2.3 From 82975d2984851e9385fbb3bf1fe9c1786369aba6 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 01:51:34 +0200 Subject: Take reader environment directly from TypecheckedSource. --- src/Haddock/Interface/Create.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index ed51734d..d0b8b14f 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -35,7 +35,7 @@ import HscTypes import Name import Bag import RdrName -import TcRnTypes (tcg_warns) +import TcRnTypes import FastString (unpackFS) @@ -51,7 +51,7 @@ createInterface tm flags modMap instIfaceMap = do dflags = ms_hspp_opts ms instances = modInfoInstances mi exportedNames = modInfoExports mi - warnings = tcg_warns . fst . tm_internals_ $ tm + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -62,9 +62,17 @@ createInterface tm flags modMap instIfaceMap = do return (emptyRnGroup, Nothing, Nothing) Just (x, _, y, z) -> return (x, y, z) +{- -- The pattern-match should not fail, because createInterface is only -- done on loaded modules. - Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl) + gre0 <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl) + gre <- + case gre0 of + Nothing -> do + liftErrMsg $ tell [ "Warning: Could not find module in renaming environment: " ++ pretty mdl ] + return emptyGlobalRdrEnv + Just gre -> return gre +-} opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl let opts -- cgit v1.2.3 From 3f6a3f1983a9414e650a6dff0c7b0e824c8d83fe Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 01:55:20 +0200 Subject: Cleanup. --- src/Haddock/Interface/Create.hs | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index d0b8b14f..5ba763cb 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -51,6 +51,7 @@ createInterface tm flags modMap instIfaceMap = do dflags = ms_hspp_opts ms instances = modInfoInstances mi exportedNames = modInfoExports mi + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm -- The renamed source should always be available to us, but it's best @@ -62,18 +63,6 @@ createInterface tm flags modMap instIfaceMap = do return (emptyRnGroup, Nothing, Nothing) Just (x, _, y, z) -> return (x, y, z) -{- - -- The pattern-match should not fail, because createInterface is only - -- done on loaded modules. - gre0 <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl) - gre <- - case gre0 of - Nothing -> do - liftErrMsg $ tell [ "Warning: Could not find module in renaming environment: " ++ pretty mdl ] - return emptyGlobalRdrEnv - Just gre -> return gre --} - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl let opts | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 -- cgit v1.2.3 From 563302747deca1c66dff8ddf260e23153d310c73 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 02:16:15 +0200 Subject: Don't filter out unexported names from the four maps - fixes a regression. --- src/Haddock/Interface/Create.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 5ba763cb..94575209 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -77,7 +77,7 @@ createInterface tm flags modMap instIfaceMap = do localInsts = filter (nameIsLocalOrFrom mdl . getName) instances (docMap0, argMap, subMap, declMap) <- - liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs + liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs let docMap = addWarnings warnings gre exportedNames docMap0 maps = (docMap, argMap, subMap, declMap) @@ -203,10 +203,9 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) mkMaps :: DynFlags -> GlobalRdrEnv -> [Instance] - -> [Name] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps -mkMaps dflags gre instances exports decls = do +mkMaps dflags gre instances decls = do (a, b, c, d) <- unzip4 <$> mapM mappings decls return (f a, f b, f c, f d) where @@ -220,7 +219,7 @@ mkMaps dflags gre instances exports decls = do m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m return (doc, m') (doc, args) <- declDoc docStrs (typeDocs decl) - let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ] + let subs = subordinates decl (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs let ns = names decl subNs = [ n | (n, _, _) <- subs ] @@ -235,7 +234,7 @@ mkMaps dflags gre instances exports decls = do names :: HsDecl Name -> [Name] names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2]. - names decl = filter (`elem` exports) (getMainDeclBinder decl) + names decl = getMainDeclBinder decl -- Note [2]: -- cgit v1.2.3 From bc89bcc2b076c13ad559543ebba43603c8ab990c Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 02:40:34 +0200 Subject: Fix crash when using --qual. Naughty GHC API! --- src/Haddock/Backends/Xhtml/Names.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 7c2375cf..274078a6 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -52,7 +52,10 @@ ppDocName qual docName = case docName of Documented name mdl -> linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl - Undocumented name -> ppQualifyName qual name (nameModule name) + Undocumented name + | isExternalName name || isWiredInName name -> + ppQualifyName qual name (nameModule name) + | otherwise -> ppName name -- | Render a name depending on the selected qualification mode -- cgit v1.2.3 From a2bcbcffde1e78a6031132bdf4a1a605978352a8 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 1 Apr 2012 13:03:07 +0200 Subject: add QualOption type for distinction between qualification argument given by the user and the actual qualification for a concrete module --- src/Haddock/Backends/Xhtml.hs | 14 +++++--------- src/Haddock/Backends/Xhtml/Names.hs | 8 ++------ src/Haddock/Options.hs | 10 +++++----- src/Haddock/Types.hs | 32 +++++++++++++++++++++++++++----- src/Main.hs | 3 ++- 5 files changed, 41 insertions(+), 26 deletions(-) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 84468610..686bd36b 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -66,7 +66,7 @@ ppHtml :: String -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) - -> Qualification -- ^ How to qualify names + -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> IO () @@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents - prologue debug qual + prologue debug (makeContentsQual qual) when (isNothing maybe_index_url) $ ppHtmlIndex odir doctitle maybe_package @@ -461,7 +461,7 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> Qualification + -> Maybe String -> Maybe String -> Bool -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url @@ -469,10 +469,7 @@ ppHtmlModule odir doctitle themes let mdl = ifaceMod iface mdl_str = moduleString mdl - real_qual = case qual of - LocalQual Nothing -> LocalQual (Just mdl) - RelativeQual Nothing -> RelativeQual (Just mdl) - _ -> qual + real_qual = makeModuleQual qual mdl html = headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ bodyHtml doctitle (Just iface) @@ -484,8 +481,7 @@ ppHtmlModule odir doctitle themes createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug - + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes -> Interface -> Bool -> Qualification -> Bool -> IO () diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 274078a6..9963fffc 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -64,14 +64,10 @@ ppQualifyName qual name mdl = case qual of NoQual -> ppName name FullQual -> ppFullQualName mdl name - -- this is just in case, it should never happen - LocalQual Nothing -> ppQualifyName FullQual name mdl - LocalQual (Just localmdl) + LocalQual localmdl | moduleString mdl == moduleString localmdl -> ppName name | otherwise -> ppFullQualName mdl name - -- again, this never happens - RelativeQual Nothing -> ppQualifyName FullQual name mdl - RelativeQual (Just localmdl) -> + RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppQualifyName NoQual name mdl diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 4e42fd32..3292ba16 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -229,13 +229,13 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] -qualification :: [Flag] -> Qualification +qualification :: [Flag] -> QualOption qualification flags = case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - "full":_ -> FullQual - "local":_ -> LocalQual Nothing - "relative":_ -> RelativeQual Nothing - _ -> NoQual + "full":_ -> OptFullQual + "local":_ -> OptLocalQual + "relative":_ -> OptRelativeQual + _ -> OptNoQual verbosity :: [Flag] -> Verbosity diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 22d2f6ae..de0cc3d9 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -374,12 +374,34 @@ data DocOption -- | Option controlling how to qualify names +data QualOption + = OptNoQual -- ^ Never qualify any names. + | OptFullQual -- ^ Qualify all names fully. + | OptLocalQual -- ^ Qualify all imported names fully. + | OptRelativeQual -- ^ Like local, but strip module prefix + -- from modules in the same hierarchy. + data Qualification - = NoQual -- ^ Never qualify any names. - | FullQual -- ^ Qualify all names fully. - | LocalQual (Maybe Module) -- ^ Qualify all imported names fully. - | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix. - -- from modules in the same hierarchy. + = NoQual + | FullQual + | LocalQual Module + | RelativeQual Module + -- ^ @Maybe Module@ contains the current module. + -- This way we can distinguish imported and local identifiers. + +makeContentsQual :: QualOption -> Qualification +makeContentsQual qual = + case qual of + OptNoQual -> NoQual + _ -> FullQual + +makeModuleQual :: QualOption -> Module -> Qualification +makeModuleQual qual mdl = + case qual of + OptLocalQual -> LocalQual mdl + OptRelativeQual -> RelativeQual mdl + OptFullQual -> FullQual + OptNoQual -> NoQual ----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index 0a3c9ffc..e423cf03 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -228,7 +228,8 @@ render flags ifaces installedIfaces srcMap = do when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty opt_qualification + allVisibleIfaces True prologue pretty + (makeContentsQual opt_qualification) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do -- cgit v1.2.3 From 29861370dd56f59557c3bcecd53fba0f88a89792 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 1 Apr 2012 16:25:02 +0200 Subject: emit an error message when the --qual option is used incorrectly --- src/Haddock/Options.hs | 13 ++++++++----- src/Main.hs | 6 +++++- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 3292ba16..537bffac 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -229,13 +229,16 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] -qualification :: [Flag] -> QualOption +qualification :: [Flag] -> Either String QualOption qualification flags = case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - "full":_ -> OptFullQual - "local":_ -> OptLocalQual - "relative":_ -> OptRelativeQual - _ -> OptNoQual + [] -> Right OptNoQual + ["none"] -> Right OptNoQual + ["full"] -> Right OptFullQual + ["local"] -> Right OptLocalQual + ["relative"] -> Right OptRelativeQual + [arg] -> Left $ "unknown qualification type " ++ show arg + _:_ -> Left "qualification option given multiple times" verbosity :: [Flag] -> Verbosity diff --git a/src/Main.hs b/src/Main.hs index e423cf03..7d83866a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -189,6 +189,11 @@ renderStep flags pkgs interfaces = do render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () render flags ifaces installedIfaces srcMap = do + opt_qualification <- + case qualification flags of + Left msg -> throwE msg + Right q -> return q + let title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags @@ -198,7 +203,6 @@ render flags ifaces installedIfaces srcMap = do opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags - opt_qualification = qualification flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] -- cgit v1.2.3 From b8845b879d968c2888091ca2dd1bc7bdc208a166 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 18:10:30 +0200 Subject: Don't crash on unicode strings in doc comments. --- src/Haddock/Lex.x | 3 ++- tests/html-tests/tests/Unicode.hs | 6 ++++++ tests/html-tests/tests/Unicode.hs.disabled | 6 ------ 3 files changed, 8 insertions(+), 7 deletions(-) create mode 100644 tests/html-tests/tests/Unicode.hs delete mode 100644 tests/html-tests/tests/Unicode.hs.disabled diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index f65aee8c..b9ebe688 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -34,6 +34,7 @@ import Data.Char import Data.Word (Word8) import Numeric import System.IO.Unsafe +import Debug.Trace } $ws = $white # \n @@ -181,7 +182,7 @@ tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para i go inp@(pos, _, str) sc = case alexScan inp sc of AlexEOF -> [] - AlexError _ -> error "lexical error" + AlexError _ -> [] AlexSkip inp' _ -> go inp' sc AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags diff --git a/tests/html-tests/tests/Unicode.hs b/tests/html-tests/tests/Unicode.hs new file mode 100644 index 00000000..d5bbf445 --- /dev/null +++ b/tests/html-tests/tests/Unicode.hs @@ -0,0 +1,6 @@ +module Unicode where + +-- | γλώσσα +x :: Int +x = 1 + diff --git a/tests/html-tests/tests/Unicode.hs.disabled b/tests/html-tests/tests/Unicode.hs.disabled deleted file mode 100644 index d5bbf445..00000000 --- a/tests/html-tests/tests/Unicode.hs.disabled +++ /dev/null @@ -1,6 +0,0 @@ -module Unicode where - --- | γλώσσα -x :: Int -x = 1 - -- cgit v1.2.3 From faf1c0231e199206ff26c13f982d853bf81517f3 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 20:13:35 +0200 Subject: Add test for --ignore-all-exports flag/ignore-exports pragma. --- tests/html-tests/tests/IgnoreExports.hs | 10 +++ tests/html-tests/tests/IgnoreExports.html.ref | 101 ++++++++++++++++++++++++++ 2 files changed, 111 insertions(+) create mode 100644 tests/html-tests/tests/IgnoreExports.hs create mode 100644 tests/html-tests/tests/IgnoreExports.html.ref diff --git a/tests/html-tests/tests/IgnoreExports.hs b/tests/html-tests/tests/IgnoreExports.hs new file mode 100644 index 00000000..0321ad02 --- /dev/null +++ b/tests/html-tests/tests/IgnoreExports.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} +module IgnoreExports (foo) where + +-- | documentation for foo +foo :: Int +foo = 23 + +-- | documentation for bar +bar :: Int +bar = 23 diff --git a/tests/html-tests/tests/IgnoreExports.html.ref b/tests/html-tests/tests/IgnoreExports.html.ref new file mode 100644 index 00000000..4c093035 --- /dev/null +++ b/tests/html-tests/tests/IgnoreExports.html.ref @@ -0,0 +1,101 @@ + +IgnoreExports
    Safe HaskellNone

    IgnoreExports

    Synopsis

    Documentation

    foo :: Int

    documentation for foo +

    bar :: Int

    documentation for bar +

    -- cgit v1.2.3 From 979ada5bc63cba38bf570f943a3666298879bdc9 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 1 Apr 2012 22:03:25 +0200 Subject: 'abbreviate' qualification style - basic support Currently we ignore the package a module is imported from. This means that a module import would shadow another one with the same module name from a different package. --- src/Haddock/Backends/Xhtml.hs | 3 ++- src/Haddock/Backends/Xhtml/Names.hs | 22 +++++++++++++++------ src/Haddock/Interface/Create.hs | 14 +++++++++++++ src/Haddock/Options.hs | 17 ++++++++-------- src/Haddock/Types.hs | 39 ++++++++++++++++++++++++------------- 5 files changed, 67 insertions(+), 28 deletions(-) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 686bd36b..fc94e7d6 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -468,8 +468,9 @@ ppHtmlModule odir doctitle themes maybe_contents_url maybe_index_url unicode qual debug iface = do let mdl = ifaceMod iface + abbrevs = ifaceModuleAbbrevs iface mdl_str = moduleString mdl - real_qual = makeModuleQual qual mdl + real_qual = makeModuleQual qual abbrevs mdl html = headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ bodyHtml doctitle (Just iface) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 9963fffc..88ba14dc 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -24,6 +24,7 @@ import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) +import qualified Data.Map as M import qualified Data.List as List import GHC @@ -64,24 +65,33 @@ ppQualifyName qual name mdl = case qual of NoQual -> ppName name FullQual -> ppFullQualName mdl name - LocalQual localmdl - | moduleString mdl == moduleString localmdl -> ppName name - | otherwise -> ppFullQualName mdl name + LocalQual localmdl -> + if moduleString mdl == moduleString localmdl + then ppName name + else ppFullQualName mdl name RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x - Just [] -> ppQualifyName NoQual name mdl + Just [] -> ppName name -- sub-module, A.B.x -> B.x Just ('.':m) -> toHtml $ m ++ '.' : getOccString name -- some module with same prefix, ABC.x -> ABC.x - Just _ -> ppQualifyName FullQual name mdl + Just _ -> ppFullQualName mdl name -- some other module, D.x -> D.x - Nothing -> ppQualifyName FullQual name mdl + Nothing -> ppFullQualName mdl name + AbbreviateQual abbrevs localmdl -> + case (moduleString mdl == moduleString localmdl, + M.lookup (moduleName mdl) abbrevs) of + (False, Just abbrev) -> ppQualName abbrev name + _ -> ppName name ppFullQualName :: Module -> Name -> Html ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name +ppQualName :: ModuleName -> Name -> Html +ppQualName mdlName name = + toHtml $ moduleNameString mdlName ++ '.' : getOccString name ppName :: Name -> Html ppName name = toHtml (getOccString name) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 94575209..9f183432 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -30,6 +30,7 @@ import Control.Applicative import Control.Monad import qualified Data.Traversable as T +import qualified SrcLoc import GHC hiding (flags) import HscTypes import Name @@ -106,6 +107,18 @@ createInterface tm flags modMap instIfaceMap = do | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems + let abbrevs = + case tm_renamed_source tm of + Nothing -> M.empty + Just (_,impDecls,_,_) -> + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + abbrev <- ideclAs impDecl + return + (case ideclName impDecl of SrcLoc.L _ name -> name, + abbrev)) + impDecls + return Interface { ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, @@ -123,6 +136,7 @@ createInterface tm flags modMap instIfaceMap = do ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, ifaceSubMap = subMap, + ifaceModuleAbbrevs = abbrevs, ifaceInstances = instances, ifaceHaddockCoverage = coverage } diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 537bffac..792c0be3 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -126,7 +126,7 @@ options backwardsCompat = Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading", Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL") - "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'", + "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'abbreviate'", Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) @@ -232,13 +232,14 @@ optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] qualification :: [Flag] -> Either String QualOption qualification flags = case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - [] -> Right OptNoQual - ["none"] -> Right OptNoQual - ["full"] -> Right OptFullQual - ["local"] -> Right OptLocalQual - ["relative"] -> Right OptRelativeQual - [arg] -> Left $ "unknown qualification type " ++ show arg - _:_ -> Left "qualification option given multiple times" + [] -> Right OptNoQual + ["none"] -> Right OptNoQual + ["full"] -> Right OptFullQual + ["local"] -> Right OptLocalQual + ["relative"] -> Right OptRelativeQual + ["abbreviate"] -> Right OptAbbreviateQual + [arg] -> Left $ "unknown qualification type " ++ show arg + _:_ -> Left "qualification option given multiple times" verbosity :: [Flag] -> Verbosity diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index de0cc3d9..2195faf5 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -103,12 +103,15 @@ data Interface = Interface -- module. , ifaceVisibleExports :: ![Name] + -- | Abbreviations of module imports as in @import A.B.C as C@. + , ifaceModuleAbbrevs :: AbbreviationMap + -- | Instances exported by the module. , ifaceInstances :: ![Instance] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. - , ifaceHaddockCoverage :: (Int,Int) + , ifaceHaddockCoverage :: (Int,Int) } @@ -375,18 +378,27 @@ data DocOption -- | Option controlling how to qualify names data QualOption - = OptNoQual -- ^ Never qualify any names. - | OptFullQual -- ^ Qualify all names fully. - | OptLocalQual -- ^ Qualify all imported names fully. - | OptRelativeQual -- ^ Like local, but strip module prefix - -- from modules in the same hierarchy. + = OptNoQual -- ^ Never qualify any names. + | OptFullQual -- ^ Qualify all names fully. + | OptLocalQual -- ^ Qualify all imported names fully. + | OptRelativeQual -- ^ Like local, but strip module prefix + -- from modules in the same hierarchy. + | OptAbbreviateQual -- ^ Uses abbreviations of module names + -- as suggested by module import renamings. + -- However, we are unfortunately not able + -- to maintain the original qualifications. + -- Image a re-export of a whole module, + -- how could the re-exported identifiers be qualified? + +type AbbreviationMap = Map ModuleName ModuleName data Qualification = NoQual | FullQual | LocalQual Module | RelativeQual Module - -- ^ @Maybe Module@ contains the current module. + | AbbreviateQual AbbreviationMap Module + -- ^ @Module@ contains the current module. -- This way we can distinguish imported and local identifiers. makeContentsQual :: QualOption -> Qualification @@ -395,13 +407,14 @@ makeContentsQual qual = OptNoQual -> NoQual _ -> FullQual -makeModuleQual :: QualOption -> Module -> Qualification -makeModuleQual qual mdl = +makeModuleQual :: QualOption -> AbbreviationMap -> Module -> Qualification +makeModuleQual qual abbrevs mdl = case qual of - OptLocalQual -> LocalQual mdl - OptRelativeQual -> RelativeQual mdl - OptFullQual -> FullQual - OptNoQual -> NoQual + OptLocalQual -> LocalQual mdl + OptRelativeQual -> RelativeQual mdl + OptAbbreviateQual -> AbbreviateQual abbrevs mdl + OptFullQual -> FullQual + OptNoQual -> NoQual ----------------------------------------------------------------------------- -- cgit v1.2.3 From 162364b177c3982c67c842d310aead45434a3760 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 1 Apr 2012 21:46:04 +0200 Subject: Check qualification option before processing modules. --- src/Main.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 4f0784eb..8c15661d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -127,9 +127,13 @@ main :: IO () main = handleTopExceptions $ do -- Parse command-line flags and handle some of them initially. + -- TODO: unify all of this (and some of what's in the 'render' function), + -- into one function that returns a record with a field for each option, + -- or which exits with an error or help message. args <- getArgs (flags, files) <- parseHaddockOpts args shortcutFlags flags + qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -140,7 +144,7 @@ main = handleTopExceptions $ do Nothing -> return () -- Render the interfaces. - renderStep flags packages ifaces + renderStep flags qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -150,7 +154,7 @@ main = handleTopExceptions $ do packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags) -- Render even though there are no input files (usually contents/index). - renderStep flags packages [] + renderStep flags qual packages [] readPackagesAndProcessModules :: [Flag] -> [String] @@ -176,24 +180,19 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep flags pkgs interfaces = do +renderStep :: [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep flags qual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] - render flags interfaces installedIfaces srcMap + render flags qual interfaces installedIfaces srcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render flags ifaces installedIfaces srcMap = do - - opt_qualification <- - case qualification flags of - Left msg -> throwE msg - Right q -> return q +render :: [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render flags qual ifaces installedIfaces srcMap = do let title = fromMaybe "" (optTitle flags) @@ -234,14 +233,14 @@ render flags ifaces installedIfaces srcMap = do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty - (makeContentsQual opt_qualification) + (makeContentsQual qual) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do ppHtml title pkgStr visibleIfaces odir prologue themes sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode opt_qualification + opt_contents_url opt_index_url unicode qual pretty copyHtmlBits odir libDir themes -- cgit v1.2.3 From c3d370ad042eeeb9f8afc3bf3e99cbbcb9407d60 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Mon, 2 Apr 2012 00:19:36 +0200 Subject: abbreviated qualification: use Packages.lookupModuleInAllPackages for finding the package that a module belongs to --- src/Haddock/Backends/Xhtml/Names.hs | 2 +- src/Haddock/Interface/Create.hs | 41 ++++++++++++++++++++++++++++--------- src/Haddock/Types.hs | 2 +- 3 files changed, 33 insertions(+), 12 deletions(-) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 88ba14dc..863e5f90 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -81,7 +81,7 @@ ppQualifyName qual name mdl = Nothing -> ppFullQualName mdl name AbbreviateQual abbrevs localmdl -> case (moduleString mdl == moduleString localmdl, - M.lookup (moduleName mdl) abbrevs) of + M.lookup mdl abbrevs) of (False, Just abbrev) -> ppQualName abbrev name _ -> ppName name diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 9f183432..b9ca6d8c 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -30,6 +30,8 @@ import Control.Applicative import Control.Monad import qualified Data.Traversable as T +import qualified Packages +import qualified Module import qualified SrcLoc import GHC hiding (flags) import HscTypes @@ -108,16 +110,7 @@ createInterface tm flags modMap instIfaceMap = do | otherwise = exportItems let abbrevs = - case tm_renamed_source tm of - Nothing -> M.empty - Just (_,impDecls,_,_) -> - M.fromList $ - mapMaybe (\(SrcLoc.L _ impDecl) -> do - abbrev <- ideclAs impDecl - return - (case ideclName impDecl of SrcLoc.L _ name -> name, - abbrev)) - impDecls + mkAbbrevMap dflags $ tm_renamed_source tm return Interface { ifaceMod = mdl, @@ -141,6 +134,34 @@ createInterface tm flags modMap instIfaceMap = do ifaceHaddockCoverage = coverage } +mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAbbrevMap dflags mRenamedSource = + case mRenamedSource of + Nothing -> M.empty + Just (_,impDecls,_,_) -> + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + abbrev <- ideclAs impDecl + return $ + (lookupModuleDyn dflags + (fmap Module.fsToPackageId $ + ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + abbrev)) + impDecls + +-- similar to GHC.lookupModule +lookupModuleDyn :: + DynFlags -> Maybe PackageId -> ModuleName -> Module +lookupModuleDyn _ (Just pkgId) mdlName = + Module.mkModule pkgId mdlName +lookupModuleDyn dflags Nothing mdlName = + flip Module.mkModule mdlName $ + case filter snd $ + Packages.lookupModuleInAllPackages dflags mdlName of + (pkgId,_):_ -> Packages.packageConfigId pkgId + [] -> Module.mainPackageId + ------------------------------------------------------------------------------- -- Warnings diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 2195faf5..7a6d7bb9 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -390,7 +390,7 @@ data QualOption -- Image a re-export of a whole module, -- how could the re-exported identifiers be qualified? -type AbbreviationMap = Map ModuleName ModuleName +type AbbreviationMap = Map Module ModuleName data Qualification = NoQual -- cgit v1.2.3 From 3eb6d272850950e4d0c41ed1169258e8c332dbed Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Mon, 2 Apr 2012 00:29:05 +0200 Subject: qualification style 'abbreviated' -> 'aliased' --- src/Haddock/Backends/Xhtml.hs | 4 ++-- src/Haddock/Backends/Xhtml/Names.hs | 6 +++--- src/Haddock/Interface/Create.hs | 14 +++++++------- src/Haddock/Options.hs | 4 ++-- src/Haddock/Types.hs | 16 ++++++++-------- 5 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index fc94e7d6..94ca6d10 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -468,9 +468,9 @@ ppHtmlModule odir doctitle themes maybe_contents_url maybe_index_url unicode qual debug iface = do let mdl = ifaceMod iface - abbrevs = ifaceModuleAbbrevs iface + aliases = ifaceModuleAliases iface mdl_str = moduleString mdl - real_qual = makeModuleQual qual abbrevs mdl + real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ bodyHtml doctitle (Just iface) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 863e5f90..48d0f7f1 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -79,10 +79,10 @@ ppQualifyName qual name mdl = Just _ -> ppFullQualName mdl name -- some other module, D.x -> D.x Nothing -> ppFullQualName mdl name - AbbreviateQual abbrevs localmdl -> + AliasedQual aliases localmdl -> case (moduleString mdl == moduleString localmdl, - M.lookup mdl abbrevs) of - (False, Just abbrev) -> ppQualName abbrev name + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName alias name _ -> ppName name diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index b9ca6d8c..a0bfde42 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -109,8 +109,8 @@ createInterface tm flags modMap instIfaceMap = do | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems - let abbrevs = - mkAbbrevMap dflags $ tm_renamed_source tm + let aliases = + mkAliasMap dflags $ tm_renamed_source tm return Interface { ifaceMod = mdl, @@ -129,25 +129,25 @@ createInterface tm flags modMap instIfaceMap = do ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, ifaceSubMap = subMap, - ifaceModuleAbbrevs = abbrevs, + ifaceModuleAliases = aliases, ifaceInstances = instances, ifaceHaddockCoverage = coverage } -mkAbbrevMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAbbrevMap dflags mRenamedSource = +mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap dflags mRenamedSource = case mRenamedSource of Nothing -> M.empty Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do - abbrev <- ideclAs impDecl + alias <- ideclAs impDecl return $ (lookupModuleDyn dflags (fmap Module.fsToPackageId $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), - abbrev)) + alias)) impDecls -- similar to GHC.lookupModule diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 792c0be3..46f9def7 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -126,7 +126,7 @@ options backwardsCompat = Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading", Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL") - "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'abbreviate'", + "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'", Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) @@ -237,7 +237,7 @@ qualification flags = ["full"] -> Right OptFullQual ["local"] -> Right OptLocalQual ["relative"] -> Right OptRelativeQual - ["abbreviate"] -> Right OptAbbreviateQual + ["aliased"] -> Right OptAliasedQual [arg] -> Left $ "unknown qualification type " ++ show arg _:_ -> Left "qualification option given multiple times" diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 7a6d7bb9..97d56a52 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -103,8 +103,8 @@ data Interface = Interface -- module. , ifaceVisibleExports :: ![Name] - -- | Abbreviations of module imports as in @import A.B.C as C@. - , ifaceModuleAbbrevs :: AbbreviationMap + -- | Aliases of module imports as in @import A.B.C as C@. + , ifaceModuleAliases :: AliasMap -- | Instances exported by the module. , ifaceInstances :: ![Instance] @@ -383,21 +383,21 @@ data QualOption | OptLocalQual -- ^ Qualify all imported names fully. | OptRelativeQual -- ^ Like local, but strip module prefix -- from modules in the same hierarchy. - | OptAbbreviateQual -- ^ Uses abbreviations of module names + | OptAliasedQual -- ^ Uses aliases of module names -- as suggested by module import renamings. -- However, we are unfortunately not able -- to maintain the original qualifications. -- Image a re-export of a whole module, -- how could the re-exported identifiers be qualified? -type AbbreviationMap = Map Module ModuleName +type AliasMap = Map Module ModuleName data Qualification = NoQual | FullQual | LocalQual Module | RelativeQual Module - | AbbreviateQual AbbreviationMap Module + | AliasedQual AliasMap Module -- ^ @Module@ contains the current module. -- This way we can distinguish imported and local identifiers. @@ -407,12 +407,12 @@ makeContentsQual qual = OptNoQual -> NoQual _ -> FullQual -makeModuleQual :: QualOption -> AbbreviationMap -> Module -> Qualification -makeModuleQual qual abbrevs mdl = +makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification +makeModuleQual qual aliases mdl = case qual of OptLocalQual -> LocalQual mdl OptRelativeQual -> RelativeQual mdl - OptAbbreviateQual -> AbbreviateQual abbrevs mdl + OptAliasedQual -> AliasedQual aliases mdl OptFullQual -> FullQual OptNoQual -> NoQual -- cgit v1.2.3 From e4eceaeeb6e99ef9349fe7e99d2ab4d152f96484 Mon Sep 17 00:00:00 2001 From: David Terei Date: Tue, 3 Apr 2012 17:58:02 -0700 Subject: Fix reporting of modules safe haskell mode (#5989) --- src/Haddock/Interface/Create.hs | 3 ++- src/Haddock/Interface/LexParseRn.hs | 8 ++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 94575209..f68004a6 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -47,6 +47,7 @@ createInterface tm flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm + safety = modInfoSafe mi mdl = ms_mod ms dflags = ms_hspp_opts ms instances = modInfoInstances mi @@ -69,7 +70,7 @@ createInterface tm flags modMap instIfaceMap = do | otherwise = opts0 (info, mbDoc) <- do - (i, d) <- liftErrMsg $ processModuleHeader dflags gre mayDocHeader + (i, d) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader return (i, addModuleWarning warnings d) let declsWithDocs = topDecls group_ diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 61f5d6ac..56ed1b42 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -64,8 +64,9 @@ process parse dflags gre (HsDocString fs) = do Just doc -> return (Just (rename gre doc)) -processModuleHeader :: DynFlags -> GlobalRdrEnv -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) -processModuleHeader dflags gre mayStr = do +processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString + -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure @@ -79,8 +80,7 @@ processModuleHeader dflags gre mayStr = do let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi } doc' = rename gre doc return (hmi', Just doc') - let safety = Just $ showPpr $ safeHaskell dflags - return (hmi { hmi_safety = safety }, doc) + return (hmi { hmi_safety = Just $ showPpr safety }, doc) where failure = (emptyHaddockModInfo, Nothing) -- cgit v1.2.3 From b011c1a812c54e5f564fff7b15c1350ae5a78154 Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 16 May 2012 02:18:32 +0200 Subject: Update CHANGES. --- CHANGES | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/CHANGES b/CHANGES index 76ac96e2..8af677a4 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,21 @@ +Changes in version 2.11.0 + + * Show deprecation messages for identifiers + + * List identifiers declared on the same line (with a common type) separately + + * Don't crash on unicode strings in doc comments + + * Fix reporting of modules safe haskell mode + + * Fix a case where we were generating invalid xhtml + + * Better behaviour of the --qual option (no crashes, proper error messages) + + * The Haddock API restores GHC's static flags after invocation + + * Access to unexported identifiers through the Haddock API again + Changes in version 2.10.0 * Require GHC >= 7.4 -- cgit v1.2.3 From b9274d69f71e90170054a70aac5a33b6daa49df3 Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 16 May 2012 02:35:33 +0200 Subject: Mention the new aliased --qual mode in CHANGES. --- CHANGES | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index 8af677a4..527a8fe0 100644 --- a/CHANGES +++ b/CHANGES @@ -10,7 +10,10 @@ Changes in version 2.11.0 * Fix a case where we were generating invalid xhtml - * Better behaviour of the --qual option (no crashes, proper error messages) + * Improved --qual option (no crashes, proper error messages) + + * A new --qual option "aliased" which qualifies identifers by the module alias + used in the source code * The Haddock API restores GHC's static flags after invocation -- cgit v1.2.3 From d92d5a98adab5a94d34b763b9f4fd07557977ccb Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 16 May 2012 21:32:50 +0200 Subject: Bump version number. --- doc/haddock.xml | 2 +- haddock.cabal | 2 +- haddock.spec | 2 +- tests/html-tests/tests/A.html.ref | 2 +- tests/html-tests/tests/B.html.ref | 2 +- tests/html-tests/tests/Bug1.html.ref | 2 +- tests/html-tests/tests/Bug2.html.ref | 2 +- tests/html-tests/tests/Bug3.html.ref | 2 +- tests/html-tests/tests/Bug4.html.ref | 2 +- tests/html-tests/tests/Bug6.html.ref | 2 +- tests/html-tests/tests/Bug7.html.ref | 2 +- tests/html-tests/tests/Bug8.html.ref | 2 +- tests/html-tests/tests/BugDeprecated.html.ref | 2 +- tests/html-tests/tests/BugExportHeadings.html.ref | 2 +- tests/html-tests/tests/Bugs.html.ref | 2 +- tests/html-tests/tests/CrossPackageDocs.html.ref | 2 +- tests/html-tests/tests/DeprecatedClass.html.ref | 2 +- tests/html-tests/tests/DeprecatedData.html.ref | 2 +- tests/html-tests/tests/DeprecatedFunction.html.ref | 2 +- .../html-tests/tests/DeprecatedFunction2.html.ref | 2 +- .../html-tests/tests/DeprecatedFunction3.html.ref | 2 +- tests/html-tests/tests/DeprecatedModule.html.ref | 2 +- tests/html-tests/tests/DeprecatedModule2.html.ref | 2 +- tests/html-tests/tests/DeprecatedNewtype.html.ref | 2 +- .../html-tests/tests/DeprecatedTypeFamily.html.ref | 2 +- .../tests/DeprecatedTypeSynonym.html.ref | 2 +- tests/html-tests/tests/Examples.html.ref | 2 +- tests/html-tests/tests/FunArgs.html.ref | 2 +- tests/html-tests/tests/GADTRecords.html.ref | 2 +- tests/html-tests/tests/Hash.html.ref | 2 +- tests/html-tests/tests/IgnoreExports.html.ref | 2 +- tests/html-tests/tests/ModuleWithWarning.html.ref | 2 +- tests/html-tests/tests/NamedDoc.html.ref | 2 +- tests/html-tests/tests/NoLayout.html.ref | 2 +- tests/html-tests/tests/NonGreedy.html.ref | 2 +- tests/html-tests/tests/QuasiExpr.html.ref | 2 +- tests/html-tests/tests/QuasiQuote.html.ref | 2 +- tests/html-tests/tests/TH.html.ref | 2 +- tests/html-tests/tests/TH2.html.ref | 2 +- tests/html-tests/tests/Test.html.ref | 2 +- tests/html-tests/tests/Ticket112.html.ref | 2 +- tests/html-tests/tests/Ticket61.html.ref | 2 +- tests/html-tests/tests/Ticket75.html.ref | 2 +- tests/html-tests/tests/TypeFamilies.html.ref | 2 +- tests/html-tests/tests/TypeOperators.html.ref | 2 +- tests/html-tests/tests/Unicode.html.ref | 2 +- tests/html-tests/tests/Visible.html.ref | 2 +- tests/html-tests/tests/frames.html.ref | 8 +++-- tests/html-tests/tests/mini_A.html.ref | 14 ++++++++ tests/html-tests/tests/mini_B.html.ref | 14 ++++++++ tests/html-tests/tests/mini_IgnoreExports.html.ref | 37 ++++++++++++++++++++++ 51 files changed, 117 insertions(+), 50 deletions(-) create mode 100644 tests/html-tests/tests/mini_IgnoreExports.html.ref diff --git a/doc/haddock.xml b/doc/haddock.xml index 7b5a07e6..27dd69d8 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -21,7 +21,7 @@ Simon Marlow, David Waern - This document describes Haddock version 2.10.0, a Haskell + This document describes Haddock version 2.11.0, a Haskell documentation tool. diff --git a/haddock.cabal b/haddock.cabal index 84d3c2a8..9d6f1a9b 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.10.0 +version: 2.11.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/haddock.spec b/haddock.spec index 4a602e02..8b2a5599 100644 --- a/haddock.spec +++ b/haddock.spec @@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock -%define version 2.10.0 +%define version 2.11.0 %define release 1 Name: %{name} diff --git a/tests/html-tests/tests/A.html.ref b/tests/html-tests/tests/A.html.ref index 152dabf7..424ce52c 100644 --- a/tests/html-tests/tests/A.html.ref +++ b/tests/html-tests/tests/A.html.ref @@ -176,7 +176,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    Produced by Haddock version 2.10.0

    version 2.11.0

    + + - - + + - + diff --git a/tests/html-tests/tests/mini_A.html.ref b/tests/html-tests/tests/mini_A.html.ref index 3de17437..cbe50e41 100644 --- a/tests/html-tests/tests/mini_A.html.ref +++ b/tests/html-tests/tests/mini_A.html.ref @@ -39,6 +39,20 @@ window.onload = function () {pageLoad();}; >test2

    data X

    reExport

    test

    reExport

    data X

    +IgnoreExports

    IgnoreExports

    foo

    bar

    -- cgit v1.2.3 From 15aa68da3523a56475298d91f288587c4744de4a Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 17 May 2012 17:47:32 +0200 Subject: Add test for deprecated record field --- tests/html-tests/tests/DeprecatedRecord.hs | 9 ++ tests/html-tests/tests/DeprecatedRecord.html.ref | 150 +++++++++++++++++++++ .../tests/mini_DeprecatedRecord.html.ref | 33 +++++ 3 files changed, 192 insertions(+) create mode 100644 tests/html-tests/tests/DeprecatedRecord.hs create mode 100644 tests/html-tests/tests/DeprecatedRecord.html.ref create mode 100644 tests/html-tests/tests/mini_DeprecatedRecord.html.ref diff --git a/tests/html-tests/tests/DeprecatedRecord.hs b/tests/html-tests/tests/DeprecatedRecord.hs new file mode 100644 index 00000000..d44499e7 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedRecord.hs @@ -0,0 +1,9 @@ +module DeprecatedRecord where + +-- | type Foo +data Foo = Foo { + fooName :: String -- ^ some name +, fooValue :: Int -- ^ some value +} + +{-# DEPRECATED fooValue "do not use this" #-} diff --git a/tests/html-tests/tests/DeprecatedRecord.html.ref b/tests/html-tests/tests/DeprecatedRecord.html.ref new file mode 100644 index 00000000..d6648bc2 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedRecord.html.ref @@ -0,0 +1,150 @@ + +DeprecatedRecord
    Safe HaskellNone

    DeprecatedRecord

    Synopsis

    Documentation

    data Foo

    type Foo +

    Constructors

    Foo 

    Fields

    fooName :: String

    some name +

    fooValue :: Int

    Deprecated: do not use this

    some value +

    diff --git a/tests/html-tests/tests/mini_DeprecatedRecord.html.ref b/tests/html-tests/tests/mini_DeprecatedRecord.html.ref new file mode 100644 index 00000000..3d949d2d --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedRecord.html.ref @@ -0,0 +1,33 @@ + +DeprecatedRecord

    DeprecatedRecord

    data Foo

    -- cgit v1.2.3 From 986ff3c5b2e4e519171816c3ad6caa81d4808919 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 17:43:49 +0200 Subject: Use >>= instead of fmap and join --- src/Haddock/Backends/LaTeX.hs | 5 ++--- src/Haddock/Backends/Xhtml/Decl.hs | 6 ++---- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index ffe507ab..efe05b9e 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -642,8 +642,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- 'join' is in Maybe. - mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst mkFunTy a b = noLoc (HsFunTy a b) @@ -653,7 +652,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = join $ fmap fst $ lookup name subdocs + mbDoc = lookup name subdocs >>= fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 5cdc819c..3cfba1de 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -26,7 +26,6 @@ import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types -import Control.Monad ( join ) import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe @@ -589,8 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- 'join' is in Maybe. - mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst mkFunTy a b = noLoc (HsFunTy a b) @@ -602,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = join $ fmap fst $ lookup name subdocs + mbDoc = lookup name subdocs >>= fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html -- cgit v1.2.3 From e090bbc5bdc8eb34d5340e467c7157341dfdd945 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 17:14:21 +0200 Subject: newtype-wrap Doc nodes for things that may have warnings attached --- src/Haddock/Backends/Hoogle.hs | 18 ++++++----- src/Haddock/Backends/LaTeX.hs | 56 +++++++++++++++++---------------- src/Haddock/Backends/Xhtml.hs | 12 +++---- src/Haddock/Backends/Xhtml/Decl.hs | 32 +++++++++---------- src/Haddock/Backends/Xhtml/DocMarkup.hs | 10 +++--- src/Haddock/Interface/Create.hs | 12 ++++--- src/Haddock/Interface/Rename.hs | 14 ++++----- src/Haddock/Types.hs | 20 ++++++------ 8 files changed, 89 insertions(+), 85 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index e7a78fc2..98eeaab8 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -48,7 +48,7 @@ ppHoogle package version synopsis prologue ifaces odir = do hClose h ppModule :: Interface -> [String] -ppModule iface = "" : doc (ifaceDoc iface) ++ +ppModule iface = "" : ppDocumentation (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap ppExport (ifaceExportItems iface) ++ concatMap ppInstance (ifaceInstances iface) @@ -109,7 +109,7 @@ operator x = x -- How to print each export ppExport :: ExportItem Name -> [String] -ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) +ppExport (ExportDecl decl dc subdocs _) = ppDocumentation (fst dc) ++ f (unL decl) where f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d @@ -167,19 +167,19 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : f w = if w == nam then operator nam else w -- | for constructors, and named-fields... -lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) +lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> [String] lookupCon subdocs (L _ name) = case lookup name subdocs of - Just (d, _) -> d - _ -> Nothing + Just (d, _) -> ppDocumentation d + _ -> [] ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) +ppCtor dat subdocs con = lookupCon subdocs (con_name con) ++ f (con_details con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat - [doc (lookupCon subdocs (cd_fld_name r)) ++ + [lookupCon subdocs (cd_fld_name r) ++ [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] | r <- recs] @@ -197,6 +197,10 @@ ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) --------------------------------------------------------------------- -- DOCUMENTATION +ppDocumentation :: Outputable o => Documentation o -> [String] +ppDocumentation (Documentation d) = doc d + + doc :: Outputable o => Maybe (Doc o) -> [String] doc = docWith "" diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index efe05b9e..6cce753c 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -158,9 +158,7 @@ ppLaTeXModule _title odir iface = do ] description - = case ifaceRnDoc iface of - Nothing -> empty - Just doc -> docToLaTeX doc + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface body = processExports exports -- @@ -210,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) - (Nothing, argDocs) _ _) + (Documentation Nothing, argDocs) _ _) | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -276,24 +274,24 @@ ppDecl :: LHsDecl DocName -> [(DocName, DocForDecl DocName)] -> LaTeX -ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of - TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode +ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of + TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode - | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d + | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc doc d unicode + | Just _ <- tcdTyPats d -> ppDataInst loc doc d TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode - | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode - SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode - ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode + | Nothing <- tcdTyPats d -> ppTySyn loc (doc, fnArgsDoc) d unicode + | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False -ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" @@ -304,7 +302,7 @@ ppDataInst = error "data instance declarations are currently not supported by --latex" -ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) -> +ppTyInst :: Bool -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX ppTyInst _ _ _ _ _ = error "type instance declarations are currently not supported by --latex" @@ -355,13 +353,13 @@ ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) unicode | Map.null argDocs = - declWithDoc pref1 (fmap docToLaTeX doc) + declWithDoc pref1 (documentationToLaTeX doc) | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ do_args 0 sep0 typ $$ text "\\end{tabulary}\\par" $$ - maybe empty docToLaTeX doc + fromMaybe empty (documentationToLaTeX doc) where do_largs n leader (L _ t) = do_args n leader t @@ -469,9 +467,9 @@ ppFds fds unicode = ppClassDecl :: [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX -ppClassDecl instances loc mbDoc subdocs +ppClassDecl instances loc doc subdocs (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit @@ -482,7 +480,7 @@ ppClassDecl instances loc mbDoc subdocs hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds - body = catMaybes [fmap docToLaTeX mbDoc, body_] + body = catMaybes [documentationToLaTeX doc, body_] body_ | null lsigs, null ats, null at_defs = Nothing @@ -523,8 +521,8 @@ isUndocdInstance _ = Nothing -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, mbDoc) = - declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc) +ppDocInstance unicode (instHead, doc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) ppInstDecl :: Bool -> InstHead DocName -> LaTeX @@ -550,9 +548,9 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ppDataDecl :: [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX -ppDataDecl instances subdocs _loc mbDoc dataDecl unicode +ppDataDecl instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body)) @@ -562,7 +560,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - body = catMaybes [constrBit, fmap docToLaTeX mbDoc] + body = catMaybes [constrBit, documentationToLaTeX doc] (whereBit, leaders) | null cons = (empty,[]) @@ -642,7 +640,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -652,7 +650,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= fst + mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -1042,6 +1040,10 @@ docToLaTeX :: Doc DocName -> LaTeX docToLaTeX doc = markup latexMarkup doc Plain +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc + + rdrDocToLaTeX :: Doc RdrName -> LaTeX rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 94ca6d10..c5925cda 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -508,18 +508,16 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc (ExportDecl _ doc _ _) = isJust (fst doc) + has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True no_doc_at_all = not (any has_doc exports) - description - = case ifaceRnDoc iface of - Nothing -> noHtml - Just doc -> divDescription $ - sectionName << "Description" +++ docSection qual doc + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis @@ -639,7 +637,7 @@ processExport summary _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual y +++ parenList (map (ppDocName qual) subs) processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection qual doc + = nothingIf summary $ docSection_ qual doc processExport summary _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 3cfba1de..66b78cbd 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -71,9 +71,9 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual | summary = pref1 - | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc + | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc | otherwise = topDeclElem links loc docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc + subArguments qual (do_args 0 sep typ) +++ docSection qual doc where argDoc n = Map.lookup n argDocs @@ -166,12 +166,12 @@ ppTyFamHeader summary associated decl unicode qual = Nothing -> noHtml -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyFam summary associated links loc mbDoc decl unicode qual +ppTyFam summary associated links loc doc decl unicode qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ instancesBit where docname = tcdName decl @@ -206,12 +206,12 @@ ppDataInst = undefined -------------------------------------------------------------------------------- -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInst summary associated links loc mbDoc decl unicode qual +ppTyInst summary associated links loc doc decl unicode qual | summary = ppTyInstHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc + | otherwise = header_ +++ docSection qual doc where docname = tcdName decl @@ -367,12 +367,12 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html -ppClassDecl summary links instances loc mbDoc subdocs +ppClassDecl summary links instances loc d subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual - | otherwise = classheader +++ maybeDocSection qual mbDoc + | otherwise = classheader +++ docSection qual d +++ atBit +++ methodBit +++ instancesBit where classheader @@ -449,12 +449,12 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual +ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual | summary = ppShortDataDecl summary links loc dataDecl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl @@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= fst + mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index ee0a549f..cd1595f6 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( rdrDocToHtml, origDocToHtml, - docElement, docSection, maybeDocSection, + docElement, docSection, docSection_, ) where @@ -85,12 +85,12 @@ docElement el content_ = else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Doc DocName -> Html -docSection qual = (docElement thediv <<) . docToHtml qual +docSection :: Qualification -> Documentation DocName -> Html +docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc -maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html -maybeDocSection qual = maybe noHtml (docSection qual) +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual cleanup :: Doc a -> Doc a diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index ea4636fe..e2cc9959 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -117,8 +117,8 @@ createInterface tm flags modMap instIfaceMap = do ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, - ifaceDoc = mbDoc, - ifaceRnDoc = Nothing, + ifaceDoc = Documentation mbDoc, + ifaceRnDoc = Documentation Nothing, ifaceOptions = opts, ifaceDocMap = docMap, ifaceArgMap = argMap, @@ -609,10 +609,12 @@ hiValExportItem name doc = do lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) lookupDocs n docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in - let doc = (M.lookup n docMap, lookupArgDoc n) in + let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) + where + lookupDoc = Documentation . (`M.lookup` docMap) -- | Return all export items produced by an exported module. That is, we're @@ -772,7 +774,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d + hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index cffe68b8..fd2a1f10 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -47,7 +47,7 @@ renameInterface renamingEnv warnings iface = (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) (finalModuleDoc, missingNames4) - = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) + = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. @@ -142,15 +142,13 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] renameExportItems = mapM renameExportItem -renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName) -renameDocForDecl (mbDoc, fnArgsDoc) = do - mbDoc' <- renameMaybeDoc mbDoc - fnArgsDoc' <- renameFnArgsDoc fnArgsDoc - return (mbDoc', fnArgsDoc') +renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) +renameDocForDecl (doc, fnArgsDoc) = + (,) `fmap` renameDocumentation doc `ap` renameFnArgsDoc fnArgsDoc -renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName)) -renameMaybeDoc = mapM renameDoc +renameDocumentation :: Documentation Name -> RnM (Documentation DocName) +renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc renameLDocHsSyn :: LHsDocString -> RnM LHsDocString diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 97d56a52..f8d51b2b 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -67,10 +67,10 @@ data Interface = Interface , ifaceInfo :: !(HaddockModInfo Name) -- | Documentation header. - , ifaceDoc :: !(Maybe (Doc Name)) + , ifaceDoc :: !(Documentation Name) -- | Documentation header with cross-reference information. - , ifaceRnDoc :: Maybe (Doc DocName) + , ifaceRnDoc :: Documentation DocName -- | Haddock options for this module (prune, ignore-exports, etc). , ifaceOptions :: ![DocOption] @@ -214,19 +214,23 @@ data ExportItem name | ExportModule Module +newtype Documentation name = Documentation (Maybe (Doc name)) + deriving Functor + + -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (Doc name) -type DocForDecl name = (Maybe (Doc name), FnArgsDoc name) +type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Nothing, Map.empty) +noDocForDecl = (Documentation Nothing, Map.empty) unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -unrenameDocForDecl (mbDoc, fnArgsDoc) = - (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc) +unrenameDocForDecl (doc, fnArgsDoc) = + (fmap getName doc, (fmap . fmap) getName fnArgsDoc) ----------------------------------------------------------------------------- @@ -304,10 +308,6 @@ instance Monoid (Doc id) where mappend = DocAppend -unrenameDoc :: Doc DocName -> Doc Name -unrenameDoc = fmap getName - - data Example = Example { exampleExpression :: String , exampleResult :: [String] -- cgit v1.2.3 From a6bcb1e464ff33161f84c5794f5ae239604fb7e5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 17 May 2012 18:35:21 +0200 Subject: Attach warnings to `Documentation` type --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 8 ++-- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 4 +- src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- src/Haddock/Interface/Create.hs | 75 +++++++++++++++------------------ src/Haddock/Interface/Rename.hs | 3 +- src/Haddock/Types.hs | 13 ++++-- 8 files changed, 56 insertions(+), 53 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 98eeaab8..d27ca80f 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -198,7 +198,7 @@ ppCtor dat subdocs con = lookupCon subdocs (con_name con) -- DOCUMENTATION ppDocumentation :: Outputable o => Documentation o -> [String] -ppDocumentation (Documentation d) = doc d +ppDocumentation (Documentation d w) = doc d ++ doc w doc :: Outputable o => Maybe (Doc o) -> [String] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 6cce753c..31ba3b0b 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -208,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) - (Documentation Nothing, argDocs) _ _) + (Documentation Nothing Nothing, argDocs) _ _) | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -640,7 +640,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -650,7 +650,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup name subdocs >>= combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -1041,7 +1041,7 @@ docToLaTeX doc = markup latexMarkup doc Plain documentationToLaTeX :: Documentation DocName -> Maybe LaTeX -documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc +documentationToLaTeX = fmap docToLaTeX . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index c5925cda..5a3cbac0 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -508,7 +508,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc + has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 66b78cbd..21a33ea8 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup name subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index cd1595f6..052116ee 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -86,7 +86,7 @@ docElement el content_ = docSection :: Qualification -> Documentation DocName -> Html -docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation docSection_ :: Qualification -> Doc DocName -> Html diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index e2cc9959..1513349f 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -72,28 +72,23 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- do - (i, d) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader - return (i, addModuleWarning warnings d) + (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - (docMap0, argMap, subMap, declMap) <- + maps@(docMap, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs - let docMap = addWarnings warnings gre exportedNames docMap0 - maps = (docMap, argMap, subMap, declMap) - - exports0 = fmap (reverse . map unLoc) mayExports + let exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 liftErrMsg $ warnAboutFilteredDecls mdl decls - exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports + exportItems <- mkExportItems modMap mdl warnings gre exportedNames decls maps exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -117,8 +112,8 @@ createInterface tm flags modMap instIfaceMap = do ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, - ifaceDoc = Documentation mbDoc, - ifaceRnDoc = Documentation Nothing, + ifaceDoc = Documentation mbDoc (moduleWarning warnings), + ifaceRnDoc = Documentation Nothing Nothing, ifaceOptions = opts, ifaceDocMap = docMap, ifaceArgMap = argMap, @@ -169,25 +164,23 @@ lookupModuleDyn dflags Nothing mdlName = ------------------------------------------------------------------------------- --- | Add warnings to documentation. If there is a warning for an identifier --- with no documentation, create a piece of documentation that just contains --- the warning. -addWarnings :: Warnings -> GlobalRdrEnv -> [Name] -> DocMap Name -> DocMap Name -addWarnings NoWarnings _ _ dm = dm -addWarnings (WarnAll _) _ _ dm = dm -addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip (<>)) dm wm +-- FIXME: simplify +lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id) +lookupWarning NoWarnings _ _ = Nothing +lookupWarning (WarnAll _) _ _ = Nothing +lookupWarning (WarnSome ws) gre name = M.lookup name wm where wm = M.fromList [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = gre_name elt, n == name ] -addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) -addModuleWarning ws = +moduleWarning :: Warnings -> Maybe (Doc id) +moduleWarning ws = case ws of - NoWarnings -> id - WarnSome _ -> id - WarnAll w -> let d = warnToDoc w in Just . maybe d (d <>) + NoWarnings -> Nothing + WarnSome _ -> Nothing + WarnAll w -> Just (warnToDoc w) warnToDoc :: WarningTxt -> Doc id @@ -459,6 +452,7 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module + -> Warnings -> GlobalRdrEnv -> [Name] -- exported names (orig) -> [LHsDecl Name] @@ -469,10 +463,10 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod gre exportedNames decls0 + modMap thisMod warnings gre exportedNames decls0 (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of - Nothing -> fullModuleContents dflags gre maps decls + Nothing -> fullModuleContents dflags warnings gre maps decls Just exports -> liftM concat $ mapM lookupExport exports where decls = filter (not . isInstD . unLoc) decls0 @@ -483,7 +477,7 @@ mkExportItems lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps + moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (processDocString dflags gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) @@ -559,7 +553,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t warnings gre (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -579,9 +573,9 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n docMap argMap subMap) + (ds, lookupDocs n warnings gre docMap argMap subMap) | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + (ds, lookupDocs n warnings gre (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n @@ -606,15 +600,15 @@ hiValExportItem name doc = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n docMap argMap subMap = +lookupDocs :: Name -> Warnings -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings gre docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) where - lookupDoc = Documentation . (`M.lookup` docMap) + lookupDoc name = Documentation (M.lookup name docMap) (lookupWarning warnings gre name) -- | Return all export items produced by an exported module. That is, we're @@ -633,6 +627,7 @@ lookupDocs n docMap argMap subMap = moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A + -> Warnings -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A -> [LHsDecl Name] -- ^ All the declarations in A @@ -640,8 +635,8 @@ moduleExports :: Module -- ^ Module A -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps - | m == thisMod = fullModuleContents dflags gre maps decls +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps + | m == thisMod = fullModuleContents dflags warnings gre maps decls | otherwise = case M.lookup m ifaceMap of Just iface @@ -679,8 +674,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = +fullModuleContents :: DynFlags -> Warnings -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- A type signature can have multiple names, like: @@ -705,12 +700,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = lookupDocs name docMap argMap subMap in + let (doc, _) = lookupDocs name warnings gre docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = lookupDocs name docMap argMap subMap in + let (doc, subs) = lookupDocs name warnings gre docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing @@ -774,7 +769,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index fd2a1f10..7f322eca 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -148,7 +148,8 @@ renameDocForDecl (doc, fnArgsDoc) = renameDocumentation :: Documentation Name -> RnM (Documentation DocName) -renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc +renameDocumentation (Documentation mDoc mWarning) = + Documentation `fmap` mapM renameDoc mDoc `ap` mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index f8d51b2b..048a7ff7 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -24,6 +24,7 @@ import Control.Exception import Control.Arrow import Data.Typeable import Data.Map (Map) +import Data.Maybe import qualified Data.Map as Map import Data.Monoid import GHC hiding (NoLink) @@ -213,9 +214,15 @@ data ExportItem name -- | A cross-reference to another module. | ExportModule Module +data Documentation name = Documentation + { documentationDoc :: Maybe (Doc name) + , documentationWarning :: Maybe (Doc name) + } deriving Functor -newtype Documentation name = Documentation (Maybe (Doc name)) - deriving Functor + +combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation (Documentation Nothing Nothing) = Nothing +combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc) -- | Arguments and result are indexed by Int, zero-based from the left, @@ -225,7 +232,7 @@ type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, Map.empty) unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -- cgit v1.2.3 From d0fabd7e923e7a73913dd18d55d34caada3890fe Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 17 May 2012 18:49:39 +0200 Subject: Simplify lookupWarning --- src/Haddock/Interface/Create.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 1513349f..bc9bf3e0 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -164,15 +164,17 @@ lookupModuleDyn dflags Nothing mdlName = ------------------------------------------------------------------------------- --- FIXME: simplify lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id) lookupWarning NoWarnings _ _ = Nothing lookupWarning (WarnAll _) _ _ = Nothing -lookupWarning (WarnSome ws) gre name = M.lookup name wm - where - wm = M.fromList - [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n == name ] +lookupWarning (WarnSome ws) gre name = + -- there is at most one warning for each name, so it's fine to use + -- listToMaybe here + listToMaybe [warnToDoc w + | (occ, w) <- ws + , elt <- lookupGlobalRdrEnv gre occ + , gre_name elt == name + ] moduleWarning :: Warnings -> Maybe (Doc id) -- cgit v1.2.3 From 37e0abebc1e14e59ac352b0a5f633a63233f04de Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 17 May 2012 17:20:17 +0200 Subject: Add test for #205 --- tests/html-tests/tests/PruneWithWarning.hs | 9 ++++ tests/html-tests/tests/PruneWithWarning.html.ref | 55 ++++++++++++++++++++++ .../tests/mini_PruneWithWarning.html.ref | 25 ++++++++++ 3 files changed, 89 insertions(+) create mode 100644 tests/html-tests/tests/PruneWithWarning.hs create mode 100644 tests/html-tests/tests/PruneWithWarning.html.ref create mode 100644 tests/html-tests/tests/mini_PruneWithWarning.html.ref diff --git a/tests/html-tests/tests/PruneWithWarning.hs b/tests/html-tests/tests/PruneWithWarning.hs new file mode 100644 index 00000000..fefe81f5 --- /dev/null +++ b/tests/html-tests/tests/PruneWithWarning.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_HADDOCK prune #-} +module PruneWithWarning (foo, bar) where + +foo :: Int +foo = 23 +{-# DEPRECATED foo "use bar instead" #-} + +bar :: Int +bar = 42 diff --git a/tests/html-tests/tests/PruneWithWarning.html.ref b/tests/html-tests/tests/PruneWithWarning.html.ref new file mode 100644 index 00000000..7fe3edf1 --- /dev/null +++ b/tests/html-tests/tests/PruneWithWarning.html.ref @@ -0,0 +1,55 @@ + +PruneWithWarning
    Safe HaskellNone

    PruneWithWarning

    diff --git a/tests/html-tests/tests/mini_PruneWithWarning.html.ref b/tests/html-tests/tests/mini_PruneWithWarning.html.ref new file mode 100644 index 00000000..9eb3aa00 --- /dev/null +++ b/tests/html-tests/tests/mini_PruneWithWarning.html.ref @@ -0,0 +1,25 @@ + +PruneWithWarning

    PruneWithWarning

    -- cgit v1.2.3 From 095fb18d1965353ad574b93a5d744677a1c9420a Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 26 May 2012 19:00:42 +0200 Subject: Add Applicative instance for (GenRnM a) --- src/Haddock/Interface/Rename.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 7f322eca..b703da0f 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -97,6 +97,10 @@ instance Monad (GenRnM n) where instance Functor (GenRnM n) where fmap f x = do a <- x; return (f a) +instance Applicative (GenRnM n) where + pure = return + (<*>) = ap + returnRn :: a -> GenRnM n a returnRn a = RnM (const (a,[])) thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b @@ -144,12 +148,12 @@ renameExportItems = mapM renameExportItem renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) renameDocForDecl (doc, fnArgsDoc) = - (,) `fmap` renameDocumentation doc `ap` renameFnArgsDoc fnArgsDoc + (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc renameDocumentation :: Documentation Name -> RnM (Documentation DocName) renameDocumentation (Documentation mDoc mWarning) = - Documentation `fmap` mapM renameDoc mDoc `ap` mapM renameDoc mWarning + Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -- cgit v1.2.3 From 2a931d32cfdbd20d4da0cff6415a3aaf47823938 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 26 May 2012 19:20:22 +0200 Subject: Use a map for warnings, as suggested by @waern --- src/Haddock/Interface/Create.hs | 43 +++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 23 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index bc9bf3e0..50f468db 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -88,7 +88,8 @@ createInterface tm flags modMap instIfaceMap = do liftErrMsg $ warnAboutFilteredDecls mdl decls - exportItems <- mkExportItems modMap mdl warnings gre exportedNames decls maps exports + let warningMap = mkWarningMap warnings gre exportedNames + exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -163,18 +164,14 @@ lookupModuleDyn dflags Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- +type WarningMap = DocMap Name -lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id) -lookupWarning NoWarnings _ _ = Nothing -lookupWarning (WarnAll _) _ _ = Nothing -lookupWarning (WarnSome ws) gre name = - -- there is at most one warning for each name, so it's fine to use - -- listToMaybe here - listToMaybe [warnToDoc w - | (occ, w) <- ws - , elt <- lookupGlobalRdrEnv gre occ - , gre_name elt == name - ] +mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap NoWarnings _ _ = M.empty +mkWarningMap (WarnAll _) _ _ = M.empty +mkWarningMap (WarnSome ws) gre exps = M.fromList + [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] moduleWarning :: Warnings -> Maybe (Doc id) @@ -454,7 +451,7 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module - -> Warnings + -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) -> [LHsDecl Name] @@ -555,7 +552,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl (lookupDocs t warnings gre (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -575,9 +572,9 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n warnings gre docMap argMap subMap) + (ds, lookupDocs n warnings docMap argMap subMap) | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n warnings gre (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n @@ -602,15 +599,15 @@ hiValExportItem name doc = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> Warnings -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings gre docMap argMap subMap = +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) where - lookupDoc name = Documentation (M.lookup name docMap) (lookupWarning warnings gre name) + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) -- | Return all export items produced by an exported module. That is, we're @@ -629,7 +626,7 @@ lookupDocs n warnings gre docMap argMap subMap = moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A - -> Warnings + -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A -> [LHsDecl Name] -- ^ All the declarations in A @@ -676,7 +673,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> Warnings -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where @@ -702,12 +699,12 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings gre docMap argMap subMap in + let (doc, _) = lookupDocs name warnings docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = lookupDocs name warnings gre docMap argMap subMap in + let (doc, subs) = lookupDocs name warnings docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing -- cgit v1.2.3