From 3ebdc745d7bc79307986332dc71f3495099b4579 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 26 Nov 2011 04:20:12 +0100 Subject: Give preference to type over data constructors for doc comment links at renaming time. Previously this was done in the backends. Also, warn when a doc comment refers to something that is in scope but which we don't have the .haddock file for. These changes mean we can make DocIdentifier [a] into DocIdentifier a. --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 26 +++++++------------------- src/Haddock/Backends/Xhtml/DocMarkup.hs | 25 ++++++------------------- src/Haddock/Interface/Rename.hs | 10 ++++------ src/Haddock/Interface/Rn.hs | 19 +++++++++---------- src/Haddock/InterfaceFile.hs | 4 ++-- src/Haddock/Lex.x | 10 +++++----- src/Haddock/Types.hs | 5 +++-- src/Haddock/Utils.hs | 2 +- 9 files changed, 38 insertions(+), 65 deletions(-) (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 45399963..ed8d4665 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -232,7 +232,7 @@ markupTag = Markup { markupEmpty = str "", markupString = str, markupAppend = (++), - markupIdentifier = box (TagInline "a") . str . out . head, + markupIdentifier = box (TagInline "a") . str . out, markupModule = box (TagInline "a") . str, markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"), diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 5c21f0cf..fc313888 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -22,8 +22,8 @@ import qualified Pretty import GHC import OccName -import Name ( isTyConName, nameOccName ) -import RdrName ( rdrNameOcc, isRdrTc ) +import Name ( nameOccName ) +import RdrName ( rdrNameOcc ) import BasicTypes ( ipNameName ) import FastString ( unpackFS, unpackLitString ) @@ -997,9 +997,8 @@ latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- -parLatexMarkup :: (a -> LaTeX) -> (a -> Bool) - -> DocMarkup a (StringContext -> LaTeX) -parLatexMarkup ppId isTyCon = Markup { +parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) +parLatexMarkup ppId = Markup { markupParagraph = \p v -> p v <> text "\\par" $$ text "", markupEmpty = \_ -> empty, markupString = \s v -> text (fixString v s), @@ -1027,26 +1026,15 @@ parLatexMarkup ppId isTyCon = Markup { Verb -> theid Mono -> theid Plain -> text "\\haddockid" <> braces theid - where theid = ppId (choose id) - - -- If an id can refer to multiple things, we give precedence to type - -- constructors. This should ideally be done during renaming from RdrName - -- to Name, but since we will move this process from GHC into Haddock in - -- the future, we fix it here in the meantime. - -- TODO: mention this rule in the documentation. - choose [] = error "empty identifier list in HsDoc" - choose [x] = x - choose (x:y:_) - | isTyCon x = x - | otherwise = y + where theid = ppId id latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName (isTyConName . getName) +latexMarkup = parLatexMarkup ppVerbDocName rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName isRdrTc +rdrLatexMarkup = parLatexMarkup ppVerbRdrName docToLaTeX :: Doc DocName -> LaTeX diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 93536834..05ce7dbb 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -28,17 +28,15 @@ import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) import GHC -import Name -import RdrName -parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html -parHtmlMarkup ppId isTyCon = Markup { +parHtmlMarkup :: (a -> Html) -> DocMarkup a Html +parHtmlMarkup ppId = Markup { markupEmpty = noHtml, markupString = toHtml, markupParagraph = paragraph, markupAppend = (+++), - markupIdentifier = thecode . ppId . choose, + markupIdentifier = thecode . ppId, markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModuleRef (mkModuleNoPackage mdl) ref, markupEmphasis = emphasize, @@ -53,17 +51,6 @@ parHtmlMarkup ppId isTyCon = Markup { markupExample = examplesToHtml } where - -- If an id can refer to multiple things, we give precedence to type - -- constructors. This should ideally be done during renaming from RdrName - -- to Name, but since we will move this process from GHC into Haddock in - -- the future, we fix it here in the meantime. - -- TODO: mention this rule in the documentation. - choose [] = error "empty identifier list in HsDoc" - choose [x] = x - choose (x:y:_) - | isTyCon x = x - | otherwise = y - examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] exampleToHtml (Example expression result) = htmlExample @@ -77,17 +64,17 @@ parHtmlMarkup ppId isTyCon = Markup { -- ugly extra whitespace with some browsers). FIXME: Does this still apply? docToHtml :: Qualification -> Doc DocName -> Html docToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup (ppDocName qual) (isTyConName . getName) + where fmt = parHtmlMarkup (ppDocName qual) origDocToHtml :: Doc Name -> Html origDocToHtml = markup fmt . cleanup - where fmt = parHtmlMarkup ppName isTyConName + where fmt = parHtmlMarkup ppName rdrDocToHtml :: Doc RdrName -> Html rdrDocToHtml = markup fmt . cleanup - where fmt = parHtmlMarkup ppRdrName isRdrTc + where fmt = parHtmlMarkup ppRdrName docElement :: (Html -> Html) -> Html -> Html diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 88e64cfa..2c10146d 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -58,7 +58,7 @@ renameInterface renamingEnv warnings iface = -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. - missingNames = nub $ filter isExternalName + missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much (missingNames1 ++ missingNames2 ++ missingNames3) -- filter out certain built in type constructors using their string @@ -171,11 +171,9 @@ renameDoc d = case d of DocParagraph doc -> do doc' <- renameDoc doc return (DocParagraph doc') - DocIdentifier ids -> do - lkp <- getLookupRn - case [ n | (True, n) <- map lkp ids ] of - ids'@(_:_) -> return (DocIdentifier ids') - [] -> return (DocIdentifier (map Undocumented ids)) + DocIdentifier x -> do + x' <- rename x + return (DocIdentifier x') DocModule str -> return (DocModule str) DocEmphasis doc -> do doc' <- renameDoc doc diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs index d63524b6..57704db7 100644 --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -5,7 +5,7 @@ import Haddock.Types import RnEnv ( dataTcOccs ) import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName ) -import Name ( Name ) +import Name ( Name, isTyConName ) import Outputable ( ppr, showSDoc ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name @@ -13,10 +13,6 @@ rnHaddockModInfo gre hmod = let desc = hmi_description hmod in hmod { hmi_description = fmap (rnDoc gre) desc } -ids2string :: [RdrName] -> String -ids2string [] = [] -ids2string (x:_) = showSDoc $ ppr x - data Id x = Id {unId::x} instance Monad Id where (Id v)>>=f = f v; return = Id @@ -38,13 +34,16 @@ rnDoc gre = unId . do_rn doc' <- do_rn doc return (DocParagraph doc') - DocIdentifier ids -> do - let choices = concatMap dataTcOccs ids + DocIdentifier x -> do + let choices = dataTcOccs x let gres = concatMap (\rdrName -> map gre_name (lookupGRE_RdrName rdrName gre)) choices - case gres of - [] -> return (DocMonospaced (DocString (ids2string ids))) - ids' -> return (DocIdentifier ids') + return $ case gres of + [] -> DocMonospaced (DocString (showSDoc $ ppr x)) -- TODO: DocIdentifierRdrName + [a] -> DocIdentifier a + a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b + -- If an id can refer to multiple things, we give precedence to type + -- constructors. DocModule str -> return (DocModule str) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 64f8baab..c1b54b1b 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -65,9 +65,9 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 17 +binaryInterfaceVersion = 18 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 17 +binaryInterfaceVersion = 18 #else #error Unknown GHC version #endif diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index 153f6677..f65aee8c 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -121,7 +121,7 @@ data Token | TokDefStart | TokDefEnd | TokSpecial Char - | TokIdent [RdrName] + | TokIdent RdrName | TokString String | TokURL String | TokPic String @@ -209,7 +209,7 @@ begin sc = \_ _ _ cont _ -> cont sc ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags loc id of + case parseIdent dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str) @@ -220,12 +220,12 @@ ident pos str sc cont dflags = AlexPn _ line col -> mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName] -strToHsQNames dflags loc str0 = +parseIdent :: DynFlags -> RealSrcLoc -> String -> Maybe RdrName +parseIdent dflags loc str0 = let buffer = stringToStringBuffer str0 pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of - POk _ name -> Just [unLoc name] + POk _ name -> Just (unLoc name) _ -> Nothing } diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index c9b29bd0..4989a067 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -275,7 +275,8 @@ data Doc id | DocAppend (Doc id) (Doc id) | DocString String | DocParagraph (Doc id) - | DocIdentifier [id] + | DocIdentifier id +-- | DocIdentifierOutOfScope [RdrName] | DocModule String | DocEmphasis (Doc id) | DocMonospaced (Doc id) @@ -310,7 +311,7 @@ data DocMarkup id a = Markup , markupString :: String -> a , markupParagraph :: a -> a , markupAppend :: a -> a -> a - , markupIdentifier :: [id] -> a + , markupIdentifier :: id -> a , markupModule :: String -> a , markupEmphasis :: a -> a , markupMonospaced :: a -> a diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 20598263..478025d8 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -384,7 +384,7 @@ markup m DocEmpty = markupEmpty m markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) markup m (DocString s) = markupString m s markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier ids) = markupIdentifier m ids +markup m (DocIdentifier x) = markupIdentifier m x markup m (DocModule mod0) = markupModule m mod0 markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) -- cgit v1.2.3