From a566544cfd3b5ab5379f89d0b8886501c96da7fa Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 25 Jan 2012 00:44:15 +0100 Subject: Fix bug introduced in my recent refactoring. --- src/Haddock/Interface/Create.hs | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) (limited to 'src/Haddock/Interface') 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 -- cgit v1.2.3 From 527a0adf3fe43d91221ec51ffb5a6af83d56e7d3 Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 25 Jan 2012 15:19:38 +0100 Subject: Cleanup mkMaps and avoid quadratic behaviour. --- src/Haddock/Interface/Create.hs | 57 +++++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 28 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 0a0c0e2d..2bca57d0 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -160,43 +160,44 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) -mkMaps :: DynFlags -> GlobalRdrEnv -> [Instance] -> [Name] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps +mkMaps :: DynFlags + -> GlobalRdrEnv + -> [Instance] + -> [Name] + -> [(LHsDecl Name, [HsDocString])] + -> ErrMsgM Maps mkMaps dflags gre instances exports decls = do - maps <- mapM f decls - let mergeMaps (a,b,c,d) (x,y,z,w) = - (M.unionWith mappend a x, M.unionWith mappend b y, - M.unionWith mappend c z, M.unionWith mappend d w) - let emptyMaps = (M.empty, M.empty, M.empty, M.empty) - return (foldl' mergeMaps emptyMaps maps) + (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls + let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f = M.fromListWith mappend . concat + return (f dm, f am, f sm, f cm) where - instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] - - f :: (LHsDecl Name, [HsDocString]) -> ErrMsgM Maps - f (decl@(L _ d), docs) = do - mayDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs - argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs d) $ - \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc + 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 - let subs_ = subordinates d - let subs_' = filter (\(name, _, _) -> name `elem` exports) subs_ + let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ] - (subDocs, subArgMap) <- unzip <$> (forM subs_' $ \(name, mbSubDocStr, subFnArgsDocStr) -> do + (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ - \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc - return ((name, mbSubDoc), (name, subFnArgsDoc))) + lexParseRnHaddockComment dflags NormalHaddockComment gre + return ((n, mbSubDoc), (n, subFnArgsDoc))) - let subNames = map fst subDocs + let names = case decl of + -- See note [2]. + InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) + _ -> filter (`elem` exports) (getMainDeclBinder decl) - let names = case d of - InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. - _ -> filter (`elem` exports) (getMainDeclBinder d) + 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 ] + return (dm, am, sm, cm) - let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs)) - let argMap' = M.fromList [ (n, argDocs) | n <- names ] `mappend` M.fromList subArgMap - let subMap' = M.fromList [ (n, subNames) | n <- names ] - let dclMap' = M.fromList [ (n, [decl]) | n <- names ++ subNames ] - return (docMap', argMap', subMap', dclMap') + instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] -- Note [2]: -- cgit v1.2.3 From d327e3dfea1dda473c065b0e6a7da2161c9e6668 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Jan 2012 11:54:37 +0100 Subject: Add DocWarning to Doc The Xhtml backend has special markup for that, Hoogle and LaTeX reuse what we have for DocEmphasis. --- html/Classic.theme/xhaddock.css | 6 +++--- html/Ocean.std-theme/ocean.css | 4 ++++ src/Haddock/Backends/Hoogle.hs | 1 + src/Haddock/Backends/LaTeX.hs | 1 + src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 + src/Haddock/Interface/LexParseRn.hs | 1 + src/Haddock/Interface/Rename.hs | 3 +++ src/Haddock/InterfaceFile.hs | 14 ++++++++++---- src/Haddock/Types.hs | 2 ++ src/Haddock/Utils.hs | 2 ++ 10 files changed, 28 insertions(+), 7 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/html/Classic.theme/xhaddock.css b/html/Classic.theme/xhaddock.css index d6b58d22..40ea0d06 100644 --- a/html/Classic.theme/xhaddock.css +++ b/html/Classic.theme/xhaddock.css @@ -488,6 +488,6 @@ td.rdoc p { background: inherit; } - - - +.warning { + color: red; +} diff --git a/html/Ocean.std-theme/ocean.css b/html/Ocean.std-theme/ocean.css index e0ba8b0c..42238709 100644 --- a/html/Ocean.std-theme/ocean.css +++ b/html/Ocean.std-theme/ocean.css @@ -429,6 +429,10 @@ div#style-menu-holder { padding-left: 2em; } +.warning { + color: red; +} + .arguments { margin-top: -0.4em; } diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 6e3e306a..cbb5921d 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -235,6 +235,7 @@ markupTag = Markup { markupIdentifier = box (TagInline "a") . str . out, markupIdentifierUnchecked = box (TagInline "a") . str . out . snd, markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"), markupPic = const $ str " ", diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index e0a530be..ffe507ab 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1006,6 +1006,7 @@ parLatexMarkup ppId = Markup { markupIdentifier = markupId ppId, markupIdentifierUnchecked = markupId (ppVerbOccName . snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), markupMonospaced = \p _ -> tt (p Mono), markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index f506d2b8..ee0a549f 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -39,6 +39,7 @@ parHtmlMarkup qual ppId = Markup { markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModuleRef (mkModuleName mdl) ref, + markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupMonospaced = thecode, markupUnorderedList = unordList, diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index f70c5953..ebd2b8fc 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -108,6 +108,7 @@ rename gre = rn a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b -- If an id can refer to multiple things, we give precedence to type -- constructors. + DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) DocMonospaced doc -> DocMonospaced (rn doc) DocUnorderedList docs -> DocUnorderedList (map rn docs) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 691dafbc..582c2ccd 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -169,6 +169,9 @@ renameDoc d = case d of return (DocIdentifier x') DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x) DocModule str -> return (DocModule str) + DocWarning doc -> do + doc' <- renameDoc doc + return (DocWarning doc') DocEmphasis doc -> do doc' <- renameDoc doc return (DocEmphasis doc') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index fcf7fe65..e998ffec 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -65,13 +65,13 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #elif __GLASGOW_HASKELL__ == 705 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 20 #else #error Unknown GHC version #endif @@ -469,6 +469,9 @@ instance (Binary id) => Binary (Doc id) where put_ bh (DocIdentifierUnchecked x) = do putByte bh 16 put_ bh x + put_ bh (DocWarning ag) = do + putByte bh 17 + put_ bh ag get bh = do h <- getByte bh case h of @@ -523,6 +526,9 @@ instance (Binary id) => Binary (Doc id) where 16 -> do x <- get bh return (DocIdentifierUnchecked x) + 17 -> do + ag <- get bh + return (DocWarning ag) _ -> fail "invalid binary data found" diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index a3a7db15..fe4039a7 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -283,6 +283,7 @@ data Doc id | DocIdentifier id | DocIdentifierUnchecked (ModuleName, OccName) | DocModule String + | DocWarning (Doc id) | DocEmphasis (Doc id) | DocMonospaced (Doc id) | DocUnorderedList [Doc id] @@ -324,6 +325,7 @@ data DocMarkup id a = Markup , markupIdentifier :: id -> a , markupIdentifierUnchecked :: (ModuleName, OccName) -> a , markupModule :: String -> a + , markupWarning :: a -> a , markupEmphasis :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index de97ef85..9865fdf1 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -410,6 +410,7 @@ markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) @@ -436,6 +437,7 @@ idMarkup = Markup { markupIdentifier = DocIdentifier, markupIdentifierUnchecked = DocIdentifierUnchecked, markupModule = DocModule, + markupWarning = DocWarning, markupEmphasis = DocEmphasis, markupMonospaced = DocMonospaced, markupUnorderedList = DocUnorderedList, -- cgit v1.2.3 From 3dcda28c5a30652bd9ad8b69d996d8d0990902f5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Jan 2012 12:50:36 +0100 Subject: Add support for module warnings --- src/Haddock/Interface/Create.hs | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 2bca57d0..2f8e1f01 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -35,6 +35,8 @@ import HscTypes import Name import Bag import RdrName (GlobalRdrEnv) +import TcRnTypes (tcg_warns) +import FastString (unpackFS) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -49,6 +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 -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -68,7 +71,9 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader + (info, mbDoc) <- do + (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader + return (i, addModuleWarnig warnings d) let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs @@ -125,6 +130,20 @@ createInterface tm flags modMap instIfaceMap = do } +warningToDoc :: WarningTxt -> Doc id +warningToDoc w = case w of + (DeprecatedTxt msg) -> format "Deprecated: " msg + (WarningTxt msg) -> format "Warning: " msg + where + format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs + + +addModuleWarnig :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) +addModuleWarnig warnings + | WarnAll w <- warnings = let d = warningToDoc w in Just . maybe d (mappend d) + | otherwise = id + + ------------------------------------------------------------------------------- -- Doc options -- -- cgit v1.2.3 From b2c3c861ce8c9dc48622cb76beec50dffeffb328 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Jan 2012 17:53:37 +0100 Subject: Add support for warnings --- src/Haddock/Interface/Create.hs | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 2f8e1f01..76b59a80 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -79,8 +79,31 @@ createInterface tm flags modMap instIfaceMap = do (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - maps@(docMap, argMap, subMap, declMap) <- - liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs + (docs, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs + + -- Attach warnings to documentation as appropriate. If there is a warning + -- for an identifier with no documentation, create a piece of documentation, + -- that just contains the warning. + let docMap = warningMap `combine` docs + where + combine :: (Ord k, Monoid a) => Map k a -> Map k a -> Map k a + combine = M.unionWith mappend + + warningMap = case warnings of + -- NOTE: warningMap may contain more elements than xs, e.g. when + -- we have a warning for: + -- + -- data Foo = Foo + -- + -- So you can not just map over xs! + (WarnSome xs) -> foldr f M.empty exportedNames + where + f name m = case lookup (getOccName name) xs of + Just x -> M.insert name (warningToDoc x) m + Nothing -> m + _ -> M.empty + + let maps = (docMap, argMap, subMap, declMap) let exports0 = fmap (reverse . map unLoc) mayExports exports -- cgit v1.2.3 From 583e46cc674d8a75bbc12f09dae88ba7ed2b3287 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 15 Jan 2012 10:14:31 +0100 Subject: Expand type signatures in export list (fixes #192) --- src/Haddock/Interface/Create.hs | 19 +- tests/html-tests/tests/BugExportHeadings.hs | 29 +++ tests/html-tests/tests/BugExportHeadings.html.ref | 217 +++++++++++++++++++++ .../tests/mini_BugExportHeadings.html.ref | 79 ++++++++ 4 files changed, 330 insertions(+), 14 deletions(-) create mode 100644 tests/html-tests/tests/BugExportHeadings.hs create mode 100644 tests/html-tests/tests/BugExportHeadings.html.ref create mode 100644 tests/html-tests/tests/mini_BugExportHeadings.html.ref (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 76b59a80..eb0d5f0d 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -436,18 +436,10 @@ mkExportItems (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags gre maps decls - Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports + Just exports -> liftM concat $ mapM lookupExport exports where decls = filter (not . isInstD . unLoc) decls0 - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- When going throug the exported names we have to take care to detect such - -- situations and remove the duplicates. - commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) = - getMainDeclBinder sig1 == getMainDeclBinder sig2 - commaDeclared _ _ = False - lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t @@ -505,13 +497,12 @@ mkExportItems -- normal case | 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 - -- requires modifying the type signatures to "hide" the - -- names that are not exported. + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. newDecl = case decl of (L loc (SigD sig)) -> - L loc . SigD . fromJust $ filterSigNames isExported sig + L loc . SigD . fromJust $ filterSigNames (== t) sig -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. _ -> decl diff --git a/tests/html-tests/tests/BugExportHeadings.hs b/tests/html-tests/tests/BugExportHeadings.hs new file mode 100644 index 00000000..a5493a08 --- /dev/null +++ b/tests/html-tests/tests/BugExportHeadings.hs @@ -0,0 +1,29 @@ +-- test for #192 +module BugExportHeadings ( +-- * Foo + foo +-- * Bar +, bar +-- * Baz +, baz + +-- * One +, one +-- * Two +, two +-- * Three +, three +) where + +foo, bar, baz :: Int +foo = 23 +bar = 23 +baz = 23 + +one, two, three :: Int +one = 23 +two = 23 +three = 23 +{-# DEPRECATED one "for one" #-} +{-# DEPRECATED two "for two" #-} +{-# DEPRECATED three "for three" #-} diff --git a/tests/html-tests/tests/BugExportHeadings.html.ref b/tests/html-tests/tests/BugExportHeadings.html.ref new file mode 100644 index 00000000..37056334 --- /dev/null +++ b/tests/html-tests/tests/BugExportHeadings.html.ref @@ -0,0 +1,217 @@ + +BugExportHeadings
Safe HaskellNone

BugExportHeadings

Synopsis

Foo +

foo :: Int

Bar +

bar :: Int

Baz +

baz :: Int

One +

one :: Int

Deprecated: for one

Two +

two :: Int

Deprecated: for two

Three +

three :: Int

Deprecated: for three

diff --git a/tests/html-tests/tests/mini_BugExportHeadings.html.ref b/tests/html-tests/tests/mini_BugExportHeadings.html.ref new file mode 100644 index 00000000..b481720d --- /dev/null +++ b/tests/html-tests/tests/mini_BugExportHeadings.html.ref @@ -0,0 +1,79 @@ + +BugExportHeadings

BugExportHeadings

Foo +

foo

Bar +

bar

Baz +

baz

One +

one

Two +

two

Three +

three

-- cgit v1.2.3 From d9c0ac268c5f08c35a3c8a8fc792a07757182cda Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Jan 2012 17:44:45 +0100 Subject: Expand type signatures for modules without explicit export list --- src/Haddock/Interface/Create.hs | 15 +- tests/html-tests/tests/BugDeprecated.hs | 18 ++ tests/html-tests/tests/BugDeprecated.html.ref | 192 +++++++++++++++++++++ tests/html-tests/tests/mini_BugDeprecated.html.ref | 61 +++++++ 4 files changed, 285 insertions(+), 1 deletion(-) create mode 100644 tests/html-tests/tests/BugDeprecated.hs create mode 100644 tests/html-tests/tests/BugDeprecated.html.ref create mode 100644 tests/html-tests/tests/mini_BugDeprecated.html.ref (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index eb0d5f0d..2d903133 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -641,8 +641,21 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = - liftM catMaybes $ mapM mkExportItem decls + liftM catMaybes $ mapM mkExportItem (expandSig decls) where + -- A type signature can have multiple names, like: + -- foo, bar :: Types.. + -- + -- We go through the list of declarations and expand type signatures, so + -- that every type signature has exactly one name! + expandSig :: [LHsDecl name] -> [LHsDecl name] + expandSig = foldr f [] + where + f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f x xs = x : xs + mkExportItem (L _ (DocD (DocGroup lev docStr))) = do mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr return $ fmap (ExportGroup lev "") mbDoc diff --git a/tests/html-tests/tests/BugDeprecated.hs b/tests/html-tests/tests/BugDeprecated.hs new file mode 100644 index 00000000..0f7ac2eb --- /dev/null +++ b/tests/html-tests/tests/BugDeprecated.hs @@ -0,0 +1,18 @@ +module BugDeprecated where + +foo, bar, baz :: Int +foo = 23 +bar = 23 +baz = 23 +{-# DEPRECATED foo "for foo" #-} +{-# DEPRECATED bar "for bar" #-} +{-# DEPRECATED baz "for baz" #-} + +-- | some documentation for one, two and three +one, two, three :: Int +one = 23 +two = 23 +three = 23 +{-# DEPRECATED one "for one" #-} +{-# DEPRECATED two "for two" #-} +{-# DEPRECATED three "for three" #-} diff --git a/tests/html-tests/tests/BugDeprecated.html.ref b/tests/html-tests/tests/BugDeprecated.html.ref new file mode 100644 index 00000000..394ce279 --- /dev/null +++ b/tests/html-tests/tests/BugDeprecated.html.ref @@ -0,0 +1,192 @@ + +BugDeprecated
Safe HaskellNone

BugDeprecated

Synopsis

Documentation

foo :: Int

Deprecated: for foo

baz :: Int

Deprecated: for baz

bar :: Int

Deprecated: for bar

one :: Int

Deprecated: for one

some documentation for one, two and three +

three :: Int

Deprecated: for three

some documentation for one, two and three +

two :: Int

Deprecated: for two

some documentation for one, two and three +

diff --git a/tests/html-tests/tests/mini_BugDeprecated.html.ref b/tests/html-tests/tests/mini_BugDeprecated.html.ref new file mode 100644 index 00000000..f0410137 --- /dev/null +++ b/tests/html-tests/tests/mini_BugDeprecated.html.ref @@ -0,0 +1,61 @@ + +BugDeprecated

BugDeprecated

-- cgit v1.2.3 From e044d38e13f82172923dd12b68e6ee7c20f06a8c Mon Sep 17 00:00:00 2001 From: David Waern Date: Tue, 24 Jan 2012 02:53:16 +0100 Subject: Fix issues in support for warnings. * Match against local names only. * Simplify (it's OK to map over the warnings). --- src/Haddock/Interface/Create.hs | 33 +++++++++------------------------ 1 file changed, 9 insertions(+), 24 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 2d903133..f890b72e 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -34,7 +34,7 @@ import GHC hiding (flags) import HscTypes import Name import Bag -import RdrName (GlobalRdrEnv) +import RdrName import TcRnTypes (tcg_warns) import FastString (unpackFS) @@ -79,29 +79,14 @@ createInterface tm flags modMap instIfaceMap = do (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - (docs, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs - - -- Attach warnings to documentation as appropriate. If there is a warning - -- for an identifier with no documentation, create a piece of documentation, - -- that just contains the warning. - let docMap = warningMap `combine` docs - where - combine :: (Ord k, Monoid a) => Map k a -> Map k a -> Map k a - combine = M.unionWith mappend - - warningMap = case warnings of - -- NOTE: warningMap may contain more elements than xs, e.g. when - -- we have a warning for: - -- - -- data Foo = Foo - -- - -- So you can not just map over xs! - (WarnSome xs) -> foldr f M.empty exportedNames - where - f name m = case lookup (getOccName name) xs of - Just x -> M.insert name (warningToDoc x) m - Nothing -> m - _ -> M.empty + (docMap0, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs + + -- Attach warnings to documentation. If there is a warning for an identifier + -- with no documentation, create a piece of documentation that just contains + -- the warning. + let docMap = foldl' (\m (n, d) -> M.insertWith mappend n d m) docMap0 l + where l = [ (gre_name elt, warningToDoc w) | WarnSome ws <- [warnings] + , (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ ] let maps = (docMap, argMap, subMap, declMap) -- cgit v1.2.3 From e596b668926725fc19f1e4f63ffcc569cdd93eda Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 25 Jan 2012 02:20:36 +0100 Subject: Some cleanup and make sure we filter warnings through exports. --- src/Haddock/Interface/Create.hs | 80 ++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 33 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index f890b72e..06d97265 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -73,24 +73,19 @@ createInterface tm flags modMap instIfaceMap = do (info, mbDoc) <- do (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader - return (i, addModuleWarnig warnings d) + return (i, addModuleWarning warnings d) let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - (docMap0, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs + (docMap0, argMap, subMap, declMap) <- + liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs - -- Attach warnings to documentation. If there is a warning for an identifier - -- with no documentation, create a piece of documentation that just contains - -- the warning. - let docMap = foldl' (\m (n, d) -> M.insertWith mappend n d m) docMap0 l - where l = [ (gre_name elt, warningToDoc w) | WarnSome ws <- [warnings] - , (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ ] + let docMap = addWarnings warnings gre exportedNames docMap0 + maps = (docMap, argMap, subMap, declMap) - let maps = (docMap, argMap, subMap, declMap) - - let exports0 = fmap (reverse . map unLoc) mayExports + exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 @@ -103,18 +98,16 @@ createInterface tm flags modMap instIfaceMap = do let visibleNames = mkVisibleNames exportItems opts -- Measure haddock documentation coverage. - let - prunedExportItems0 = pruneExportItems exportItems - haddockable = 1 + length exportItems -- module + exports - haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - coverage = (haddockable, haddocked) + let prunedExportItems0 = pruneExportItems exportItems + haddockable = 1 + length exportItems -- module + exports + haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + coverage = (haddockable, haddocked) -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. - let - prunedExportItems - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems + let prunedExportItems + | OptPrune `elem` opts = prunedExportItems0 + | otherwise = exportItems return Interface { ifaceMod = mdl, @@ -138,20 +131,40 @@ createInterface tm flags modMap instIfaceMap = do } -warningToDoc :: WarningTxt -> Doc id -warningToDoc w = case w of +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + + +-- | 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 mappend) dm wm + where + wm = M.fromList + [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] + + +addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) +addModuleWarning ws = + case ws of + NoWarnings -> id + WarnSome _ -> id + WarnAll w -> let d = warnToDoc w in Just . maybe d (mappend d) + + +warnToDoc :: WarningTxt -> Doc id +warnToDoc w = case w of (DeprecatedTxt msg) -> format "Deprecated: " msg (WarningTxt msg) -> format "Warning: " msg where format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs -addModuleWarnig :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) -addModuleWarnig warnings - | WarnAll w <- warnings = let d = warningToDoc w in Just . maybe d (mappend d) - | otherwise = id - - ------------------------------------------------------------------------------- -- Doc options -- @@ -555,11 +568,12 @@ hiValExportItem name doc = do -- | 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 - (doc, subs) +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 subs = M.findWithDefault [] n subMap in + let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in + (doc, subDocs) -- | Return all export items produced by an exported module. That is, we're -- 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(-) (limited to 'src/Haddock/Interface') 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 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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 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(-) (limited to 'src/Haddock/Interface') 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 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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 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(-) (limited to 'src/Haddock/Interface') 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(-) (limited to 'src/Haddock/Interface') 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