From 2b2bf07fb10da33ca2edf060a6049ad7dc7b7b4c Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sun, 24 Jan 2021 16:03:45 +0300 Subject: Cleanup: fix build warnings --- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7fb71d4b..c4988480 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -624,7 +624,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just synifiedDecl -> pure synifiedDecl Nothing -> O.pprPanic "availExportItem" (O.text err) - availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn + availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) @@ -979,7 +979,7 @@ extractDecl declMap name decl _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of [] -> Left . O.showSDocUnsafe $ diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index a084af90..ad2f61c2 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -313,7 +313,7 @@ renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr fla renameLBinder = located renameBinder -- | Core renaming logic. -renameName :: (Eq name, SetName name) => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of -- cgit v1.2.3 From c31c156422785751e33c9a7a4f021ac8da77d364 Mon Sep 17 00:00:00 2001 From: Iñaki García Etxebarria Date: Wed, 31 Jul 2019 16:28:00 +0100 Subject: Add support for labeled module references Support a markdown-style way of annotating module references. For instance -- | [label]("Module.Name#anchor") will create a link that points to the same place as the module reference "Module.Name#anchor" but the text displayed on the link will be "label". --- doc/markup.rst | 5 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 7 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 15 ++-- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 9 ++- haddock-api/src/Haddock/Interface/Json.hs | 4 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 41 +++++++++-- haddock-api/src/Haddock/Types.hs | 3 + haddock-library/fixtures/Fixtures.hs | 3 + .../src/Documentation/Haddock/Markup.hs | 4 +- .../src/Documentation/Haddock/Parser.hs | 54 ++++++++++---- haddock-library/src/Documentation/Haddock/Types.hs | 14 ++-- .../test/Documentation/Haddock/ParserSpec.hs | 84 +++++++++++++++++++--- 14 files changed, 198 insertions(+), 49 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/doc/markup.rst b/doc/markup.rst index 8935b765..c0b08a40 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -982,6 +982,11 @@ is valid before turning it into a link but unlike with identifiers, whether the module is in scope isn't checked and will always be turned into a link. +It is also possible to specify alternate text for the generated link +using syntax analogous to that used for URLs: :: + + -- | This is a reference to [the main module]("Module.Main"). + Itemized and Enumerated Lists ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 58809f73..9a304030 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -325,7 +325,7 @@ markupTag dflags = Markup { markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), - markupModule = box (TagInline "a") . str, + markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label), markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupBold = box (TagInline "b"), diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index df81fd6e..2371695f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1210,7 +1210,12 @@ latexMarkup = Markup , markupAppend = \l r v -> l v . r v , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) - , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) + , markupModule = + \(ModLink m mLabel) v -> + case mLabel of + Just lbl -> inlineElem . tt $ lbl v empty + Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m + in (tt (text mdl))) , markupWarning = \p v -> p v , markupEmphasis = \p v -> inlineElem (emph (p v empty)) , markupBold = \p v -> inlineElem (bold (p v empty)) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 378d0559..7670b193 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -44,13 +44,14 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupAppend = (+++), markupIdentifier = thecode . ppId insertAnchors, markupIdentifierUnchecked = thecode . ppUncheckedLink qual, - markupModule = \m -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style - -- foo\#bar anchors - mdl' = case reverse mdl of - '\\':_ -> init mdl - _ -> mdl - in ppModuleRef (mkModuleName mdl') ref, + markupModule = \(ModLink m lbl) -> + let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef lbl (mkModuleName mdl') ref, markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupBold = strong, diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 8553cdfb..b324fa38 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -186,9 +186,12 @@ ppModule mdl = anchor ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: ModuleName -> String -> Html -ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] - << toHtml (moduleNameString mdl) +ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) +ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << lbl + -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used. diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 4e271602..95889a63 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -98,9 +98,9 @@ jsonDoc (DocIdentifierUnchecked modName) = jsonObject , ("modName", jsonString (showModName modName)) ] -jsonDoc (DocModule s) = jsonObject +jsonDoc (DocModule (ModLink m _l)) = jsonObject [ ("tag", jsonString "DocModule") - , ("string", jsonString s) + , ("string", jsonString m) ] jsonDoc (DocWarning x) = jsonObject diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index d1d6bb31..87210273 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -148,7 +148,7 @@ rename dflags gre = rn DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) - DocModule str -> pure (DocModule str) + DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l DocPic str -> pure (DocPic str) DocMathInline str -> pure (DocMathInline str) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 35f21f6c..966901df 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -46,6 +46,8 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique +import Documentation.Haddock.Parser (parseModLink) + data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, @@ -69,6 +71,18 @@ ifUnitId if_ = binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface +-- Note [The DocModule story] +-- +-- Breaking changes to the DocH type result in Haddock being unable to read +-- existing interfaces. This is especially painful for interfaces shipped +-- with GHC distributions since there is no easy way to regenerate them! +-- +-- PR #1315 introduced a breaking change to the DocModule constructor. To +-- maintain backward compatibility we +-- +-- Parse the old DocModule constructor format (tag 5) and parse the contained +-- string into a proper ModLink structure. When writing interfaces we exclusively +-- use the new DocModule format (tag 24) -- IMPORTANT: Since datatypes in the GHC API might change between major -- versions, and because we store GHC datatypes in our interface files, we need @@ -84,10 +98,10 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) -binaryInterfaceVersion = 37 +binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16] -binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] +binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion] #else #error Unsupported GHC version #endif @@ -444,6 +458,15 @@ instance Binary a => Binary (Hyperlink a) where label <- get bh return (Hyperlink url label) +instance Binary a => Binary (ModLink a) where + put_ bh (ModLink m label) = do + put_ bh m + put_ bh label + get bh = do + m <- get bh + label <- get bh + return (ModLink m label) + instance Binary Picture where put_ bh (Picture uri title) = do put_ bh uri @@ -522,9 +545,6 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocIdentifier ae) = do putByte bh 4 put_ bh ae - put_ bh (DocModule af) = do - putByte bh 5 - put_ bh af put_ bh (DocEmphasis ag) = do putByte bh 6 put_ bh ag @@ -579,6 +599,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocTable x) = do putByte bh 23 put_ bh x + -- See note [The DocModule story] + put_ bh (DocModule af) = do + putByte bh 24 + put_ bh af get bh = do h <- getByte bh @@ -598,9 +622,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 4 -> do ae <- get bh return (DocIdentifier ae) + -- See note [The DocModule story] 5 -> do af <- get bh - return (DocModule af) + return (parseModLink af) 6 -> do ag <- get bh return (DocEmphasis ag) @@ -655,6 +680,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 23 -> do x <- get bh return (DocTable x) + -- See note [The DocModule story] + 24 -> do + af <- get bh + return (DocModule af) _ -> error "invalid binary data found in the interface file" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index aa76f8f6..53d01565 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -501,6 +501,9 @@ instance NFData id => NFData (Header id) where instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (ModLink id) where + rnf (ModLink a b) = a `deepseq` b `deepseq` () + instance NFData Picture where rnf (Picture a b) = a `deepseq` b `deepseq` () diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs index 72ea8525..101bce65 100644 --- a/haddock-library/fixtures/Fixtures.hs +++ b/haddock-library/fixtures/Fixtures.hs @@ -149,6 +149,9 @@ instance ToExpr id => ToExpr (Header id) deriving instance Generic (Hyperlink id) instance ToExpr id => ToExpr (Hyperlink id) +deriving instance Generic (ModLink id) +instance ToExpr id => ToExpr (ModLink id) + deriving instance Generic Picture instance ToExpr Picture diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index 365041ee..0919737f 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -16,7 +16,7 @@ markup m (DocString s) = markupString m s 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 (DocModule (ModLink mo l)) = markupModule m (ModLink mo (fmap (markup m) l)) markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocBold d) = markupBold m (markup m d) @@ -78,7 +78,7 @@ plainMarkup plainMod plainIdent = Markup { markupAppend = (++), markupIdentifier = plainIdent, markupIdentifierUnchecked = plainMod, - markupModule = id, + markupModule = \(ModLink m lbl) -> fromMaybe m lbl, markupWarning = id, markupEmphasis = id, markupBold = id, diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index a3bba38a..bb8745a5 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -18,6 +18,7 @@ module Documentation.Haddock.Parser ( parseString, parseParas, + parseModLink, overIdentifier, toRegular, Identifier @@ -72,7 +73,7 @@ overIdentifier f d = g d g (DocString x) = DocString x g (DocParagraph x) = DocParagraph $ g x g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x - g (DocModule x) = DocModule x + g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x)) g (DocWarning x) = DocWarning $ g x g (DocEmphasis x) = DocEmphasis $ g x g (DocMonospaced x) = DocMonospaced $ g x @@ -136,6 +137,9 @@ parseString = parseText . T.pack parseText :: Text -> DocH mod Identifier parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r') +parseModLink :: String -> DocH mod id +parseModLink s = snd $ parse moduleName (T.pack s) + parseParagraph :: Text -> DocH mod Identifier parseParagraph = snd . parse p where @@ -148,6 +152,7 @@ parseParagraph = snd . parse p , mathDisplay , mathInline , markdownImage + , markdownLink , hyperlink , bold , emphasis @@ -242,7 +247,12 @@ monospace = DocMonospaced . parseParagraph -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) -moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"") +moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"") + +-- | A module name, optionally with an anchor +-- +moduleNameString :: Parser String +moduleNameString = modid `maybeFollowedBy` anchor_ where modid = intercalate "." <$> conid `Parsec.sepBy1` "." anchor_ = (++) @@ -250,13 +260,30 @@ moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"") <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c))) maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf - + conid :: Parser String conid = (:) <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) <*> many conChar conChar = Parsec.alphaNum <|> Parsec.char '_' +-- | A labeled link to an indentifier, module or url using markdown +-- syntax. +markdownLink :: Parser (DocH mod Identifier) +markdownLink = do + lbl <- markdownLinkText + choice' [ markdownModuleName lbl, markdownURL lbl ] + where + markdownModuleName lbl = do + mn <- "(" *> skipHorizontalSpace *> + "\"" *> moduleNameString <* "\"" + <* skipHorizontalSpace <* ")" + pure $ DocModule (ModLink mn (Just lbl)) + + markdownURL lbl = do + target <- markdownLinkTarget + pure $ DocHyperlink $ Hyperlink target (Just lbl) + -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. -- @@ -290,9 +317,11 @@ mathDisplay = DocMathDisplay . T.unpack -- >>> parseString "![some /emphasis/ in a description](www.site.com)" -- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) markdownImage :: Parser (DocH mod Identifier) -markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) +markdownImage = do + text <- markup stringMarkup <$> ("!" *> markdownLinkText) + url <- markdownLinkTarget + pure $ DocPic (Picture url (Just text)) where - fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) stringMarkup = plainMarkup (const "") renderIdent renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] @@ -772,22 +801,21 @@ codeblock = | otherwise = Just $ c == '\n' hyperlink :: Parser (DocH mod Identifier) -hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] +hyperlink = choice' [ angleBracketLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod Identifier) -markdownLink = DocHyperlink <$> linkParser +-- | The text for a markdown link, enclosed in square brackets. +markdownLinkText :: Parser (DocH mod Identifier) +markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]") -linkParser :: Parser (Hyperlink (DocH mod Identifier)) -linkParser = flip Hyperlink <$> label <*> (whitespace *> url) +-- | The target for a markdown link, enclosed in parenthesis. +markdownLinkTarget :: Parser String +markdownLinkTarget = whitespace *> url where - label :: Parser (Maybe (DocH mod Identifier)) - label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]") - whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 12ccd28d..252eb425 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -73,6 +73,11 @@ data Hyperlink id = Hyperlink , hyperlinkLabel :: Maybe id } deriving (Eq, Show, Functor, Foldable, Traversable) +data ModLink id = ModLink + { modLinkName :: String + , modLinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) + data Picture = Picture { pictureUri :: String , pictureTitle :: Maybe String @@ -111,7 +116,8 @@ data DocH mod id | DocIdentifier id | DocIdentifierUnchecked mod -- ^ A qualified identifier that couldn't be resolved. - | DocModule String + | DocModule (ModLink (DocH mod id)) + -- ^ A link to a module, with an optional label. | DocWarning (DocH mod id) -- ^ This constructor has no counterpart in Haddock markup. | DocEmphasis (DocH mod id) @@ -142,7 +148,7 @@ instance Bifunctor DocH where bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) bimap _ g (DocIdentifier i) = DocIdentifier (g i) bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) - bimap _ _ (DocModule s) = DocModule s + bimap f g (DocModule (ModLink m lbl)) = DocModule (ModLink m (fmap (bimap f g) lbl)) bimap f g (DocWarning doc) = DocWarning (bimap f g doc) bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) @@ -189,7 +195,7 @@ instance Bitraversable DocH where bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m - bitraverse _ _ (DocModule s) = pure (DocModule s) + bitraverse f g (DocModule (ModLink m lbl)) = DocModule <$> (ModLink m <$> traverse (bitraverse f g) lbl) bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc @@ -234,7 +240,7 @@ data DocMarkupH mod id a = Markup , markupAppend :: a -> a -> a , markupIdentifier :: id -> a , markupIdentifierUnchecked :: mod -> a - , markupModule :: String -> a + , markupModule :: ModLink a -> a , markupWarning :: a -> a , markupEmphasis :: a -> a , markupBold :: a -> a diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 1724c664..5fa73ecd 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -403,20 +403,20 @@ spec = do context "when parsing module strings" $ do it "should parse a module on its own" $ do "\"Module\"" `shouldParseTo` - DocModule "Module" + DocModule (ModLink "Module" Nothing) it "should parse a module inline" $ do "This is a \"Module\"." `shouldParseTo` - "This is a " <> DocModule "Module" <> "." + "This is a " <> DocModule (ModLink "Module" Nothing) <> "." it "can accept a simple module name" $ do - "\"Hello\"" `shouldParseTo` DocModule "Hello" + "\"Hello\"" `shouldParseTo` DocModule (ModLink "Hello" Nothing) it "can accept a module name with dots" $ do - "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World" + "\"Hello.World\"" `shouldParseTo` DocModule (ModLink "Hello.World" Nothing) it "can accept a module name with unicode" $ do - "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ" + "\"Hello.Worldλ\"" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" Nothing) it "parses a module name with a trailing dot as regular quoted string" $ do "\"Hello.\"" `shouldParseTo` "\"Hello.\"" @@ -428,19 +428,85 @@ spec = do "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\"" it "accepts a module name with unicode" $ do - "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ" + "\"Foo.Barλ\"" `shouldParseTo` DocModule (ModLink "Foo.Barλ" Nothing) it "treats empty module name as regular double quotes" $ do "\"\"" `shouldParseTo` "\"\"" it "accepts anchor reference syntax as DocModule" $ do - "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" + "\"Foo#bar\"" `shouldParseTo` DocModule (ModLink "Foo#bar" Nothing) it "accepts anchor with hyphen as DocModule" $ do - "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo#bar-baz" + "\"Foo#bar-baz\"" `shouldParseTo` DocModule (ModLink "Foo#bar-baz" Nothing) it "accepts old anchor reference syntax as DocModule" $ do - "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" + "\"Foo\\#bar\"" `shouldParseTo` DocModule (ModLink "Foo\\#bar" Nothing) + + context "when parsing labeled module links" $ do + it "parses a simple labeled module link" $ do + "[some label](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows escaping in label" $ do + "[some\\] label](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some] label")) + + it "strips leading and trailing whitespace from label" $ do + "[ some label ](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows whitespace in module name link" $ do + "[some label]( \"Some.Module\"\t )" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just "some label")) + + it "allows inline markup in the label" $ do + "[something /emphasized/](\"Some.Module\")" `shouldParseTo` + DocModule (ModLink "Some.Module" (Just ("something " <> DocEmphasis "emphasized"))) + + it "should parse a labeled module on its own" $ do + "[label](\"Module\")" `shouldParseTo` + DocModule (ModLink "Module" (Just "label")) + + it "should parse a labeled module inline" $ do + "This is a [label](\"Module\")." `shouldParseTo` + "This is a " <> DocModule (ModLink "Module" (Just "label")) <> "." + + it "can accept a labeled module name with dots" $ do + "[label](\"Hello.World\")" `shouldParseTo` DocModule (ModLink "Hello.World" (Just "label")) + + it "can accept a labeled module name with unicode" $ do + "[label](\"Hello.Worldλ\")" `shouldParseTo` DocModule (ModLink "Hello.Worldλ" (Just "label")) + + it "parses a labeled module name with a trailing dot as a hyperlink" $ do + "[label](\"Hello.\")" `shouldParseTo` + hyperlink "\"Hello.\"" (Just "label") + + it "parses a labeled module name with a space as a regular string" $ do + "[label](\"Hello World\")" `shouldParseTo` "[label](\"Hello World\")" + + it "parses a module name with invalid characters as a hyperlink" $ do + "[label](\"Hello&[{}(=*+]!\")" `shouldParseTo` + hyperlink "\"Hello&[{}(=*+]!\"" (Just "label") + + it "accepts a labeled module name with unicode" $ do + "[label](\"Foo.Barλ\")" `shouldParseTo` + DocModule (ModLink "Foo.Barλ" (Just "label")) + + it "treats empty labeled module name as empty hyperlink" $ do + "[label](\"\")" `shouldParseTo` + hyperlink "\"\"" (Just "label") + + it "accepts anchor reference syntax for labeled module name" $ do + "[label](\"Foo#bar\")" `shouldParseTo` + DocModule (ModLink "Foo#bar" (Just "label")) + + it "accepts old anchor reference syntax for labeled module name" $ do + "[label](\"Foo\\#bar\")" `shouldParseTo` + DocModule (ModLink "Foo\\#bar" (Just "label")) + + it "interprets empty label as a unlabeled module name" $ do + "[](\"Module.Name\")" `shouldParseTo` + "[](" <> DocModule (ModLink "Module.Name" Nothing) <> ")" describe "parseParas" $ do let infix 1 `shouldParseTo` -- cgit v1.2.3 From 05e2666af785f2b33395673839a5edf549901d36 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 7 Jan 2021 16:43:18 +0100 Subject: Update for Logger --- haddock-api/src/Haddock.hs | 36 ++++++++++++---------- haddock-api/src/Haddock/Interface.hs | 18 ++++++----- .../src/Haddock/Interface/AttachInstances.hs | 3 +- 3 files changed, 31 insertions(+), 26 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 2b6e2d57..49a63604 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -185,12 +185,13 @@ haddockWithGhc ghc args = handleTopExceptions $ do ghc flags' $ withDir $ do dflags <- getDynFlags + logger <- getLogger unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile)) + putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -203,7 +204,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -213,7 +214,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags unit_state flags sinceQual qual packages [] + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -262,9 +263,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption +renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do +renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -273,12 +274,12 @@ renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] +render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do +render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -368,7 +369,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do - withTiming dflags' "ppHtmlIndex" (const ()) $ do + withTiming logger dflags' "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls @@ -378,7 +379,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do - withTiming dflags' "ppHtmlContents" (const ()) $ do + withTiming logger dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls @@ -388,7 +389,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - withTiming dflags' "ppHtml" (const ()) $ do + withTiming logger dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue @@ -423,14 +424,14 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = ] when (Flag_LaTeX `elem` flags) $ do - withTiming dflags' "ppLatex" (const ()) $ do + withTiming logger dflags' "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do - withTiming dflags' "ppHyperlinkedSource" (const ()) $ do + withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () @@ -469,7 +470,8 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do -- compilation and linking. Then run the given 'Ghc' action. withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do - dynflags' <- parseGhcFlags =<< getSessionDynFlags + logger <- getLogger + dynflags' <- parseGhcFlags logger =<< getSessionDynFlags -- We disable pattern match warnings because than can be very -- expensive to check @@ -493,8 +495,8 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do go arg func True = arg : func True - parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags - parseGhcFlags dynflags = do + parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags + parseGhcFlags logger dynflags = do -- TODO: handle warnings? let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] @@ -506,7 +508,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do } flags' = filterRtsFlags flags - (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags') + (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') else return dynflags'' diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index fa1f3ee5..f3377965 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -59,15 +59,15 @@ import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) import GHC.Driver.Env -import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) +import GHC.Driver.Monad import GHC.Data.FastString (unpackFS) +import GHC.Utils.Error import GHC.Tc.Types (TcM, TcGblEnv(..)) import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) -import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs import GHC.Runtime.Loader (initializePlugins) import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..), @@ -113,7 +113,7 @@ processModules verbosity modules flags extIfaces = do mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-} - withTimingD "attachInstances" (const ()) $ do + withTimingM "attachInstances" (const ()) $ do attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..." @@ -161,7 +161,7 @@ createIfaces verbosity modules flags instIfaceMap = do targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets - loadOk <- withTimingD "load" (const ()) $ + loadOk <- withTimingM "load" (const ()) $ {-# SCC load #-} GHC.load LoadAllTargets case loadOk of @@ -212,7 +212,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do | otherwise = do hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef - (iface, modules) <- withTimingD "processModule" (const ()) $ + (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env) + "processModule" (const ()) $ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env liftIO $ do @@ -263,8 +264,11 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env unit_state = hsc_units hsc_env - (!interface, messages) <- {-# SCC createInterface #-} - withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + (!interface, messages) <- do + logger <- getLogger + dflags <- getDynFlags + {-# SCC createInterface #-} + withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 6ef0ed19..317258eb 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -127,9 +127,8 @@ attachToExportItem index expInfo getInstDoc getFixity export = cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do - dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text - liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e -- cgit v1.2.3