diff options
22 files changed, 454 insertions, 57 deletions
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..ac904273 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1072,9 +1072,13 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode , ppr_mono_lty ty unicode ] -ppr_mono_ty (HsFunTy _ _ ty1 ty2) u +ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u - , arrow u <+> ppr_mono_lty ty2 u ] + , arr <+> ppr_mono_lty ty2 u ] + where arr = case mult of + HsLinearArrow _ -> lollipop u + HsUnrestrictedArrow _ -> arrow u + HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name @@ -1210,7 +1214,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)) @@ -1363,14 +1372,18 @@ quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX +dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") +lollipop unicode = text (if unicode then "⊸" else "%1 ->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") starSymbol unicode = text (if unicode then "★" else "*") atSign unicode = text (if unicode then "@" else "@") +multAnnotation :: LaTeX +multAnnotation = text "%" + dot :: LaTeX dot = char '.' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index eeb9fa94..0b0050df 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1213,10 +1213,15 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") -ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e = +ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts - , arrow u <+> ppr_mono_lty ty2 u q e + , arr <+> ppr_mono_lty ty2 u q e ] + where arr = case mult of + HsLinearArrow _ -> lollipop u + HsUnrestrictedArrow _ -> arrow u + HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsSumTy _ tys) u q _ = 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/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index f5f64f51..238f0046 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -21,7 +21,8 @@ module Haddock.Backends.Xhtml.Utils ( keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + multAnnotation, atSign, hsep, vcat, @@ -187,13 +188,17 @@ ubxparens :: Html -> Html ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html +dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->") +lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" atSign unicode = toHtml (if unicode then "@" else "@") +multAnnotation :: Html +multAnnotation = toHtml "%" + dot :: Html dot = toHtml "." 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..69201eb0 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -46,7 +46,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique - data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, ifInstalledIfaces :: [InstalledInterface] @@ -69,6 +68,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 +95,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 +455,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 +542,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 +596,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 +619,13 @@ 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 $ DocModule ModLink + { modLinkName = af + , modLinkLabel = Nothing + } 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..de336d45 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -72,7 +72,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 @@ -148,6 +148,7 @@ parseParagraph = snd . parse p , mathDisplay , mathInline , markdownImage + , markdownLink , hyperlink , bold , emphasis @@ -242,7 +243,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 +256,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 +313,11 @@ mathDisplay = DocMathDisplay . T.unpack -- >>> parseString "" -- 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 +797,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` diff --git a/html-test/ref/LinearTypes.html b/html-test/ref/LinearTypes.html new file mode 100644 index 00000000..48ad04e2 --- /dev/null +++ b/html-test/ref/LinearTypes.html @@ -0,0 +1,108 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >LinearTypes</title + ><link href="#" rel="stylesheet" type="text/css" title="Linuwial" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><span class="caption empty" + > </span + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe-Inferred</td + ></tr + ></table + ><p class="caption" + >LinearTypes</p + ></div + ><div id="synopsis" + ><details id="syn" + ><summary + >Synopsis</summary + ><ul class="details-toggle" data-details-id="syn" + ><li class="src short" + ><a href="#" + >unrestricted</a + > :: a -> b</li + ><li class="src short" + ><a href="#" + >linear</a + > :: a %1 -> b</li + ><li class="src short" + ><a href="#" + >poly</a + > :: a %m -> b</li + ></ul + ></details + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a id="v:unrestricted" class="def" + >unrestricted</a + > :: a -> b <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >Does something unrestricted.</p + ></div + ></div + ><div class="top" + ><p class="src" + ><a id="v:linear" class="def" + >linear</a + > :: a %1 -> b <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >Does something linear.</p + ></div + ></div + ><div class="top" + ><p class="src" + ><a id="v:poly" class="def" + >poly</a + > :: a %m -> b <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >Does something polymorphic.</p + ></div + ></div + ></div + ></div + ></body + ></html +> diff --git a/html-test/src/LinearTypes.hs b/html-test/src/LinearTypes.hs new file mode 100644 index 00000000..cb4eb138 --- /dev/null +++ b/html-test/src/LinearTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LinearTypes #-} +module LinearTypes where + +-- | Does something unrestricted. +unrestricted :: a -> b +unrestricted = undefined + +-- | Does something linear. +linear :: a %1 -> b +linear = linear + +-- | Does something polymorphic. +poly :: a %m -> b +poly = poly diff --git a/latex-test/ref/LinearTypes/LinearTypes.tex b/latex-test/ref/LinearTypes/LinearTypes.tex new file mode 100644 index 00000000..cb583ca8 --- /dev/null +++ b/latex-test/ref/LinearTypes/LinearTypes.tex @@ -0,0 +1,30 @@ +\haddockmoduleheading{LinearTypes} +\label{module:LinearTypes} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module LinearTypes ( + unrestricted, linear, poly + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +unrestricted :: a -> b +\end{tabular}] +{\haddockbegindoc +Does something unrestricted.\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +linear :: a {\char '45}1 -> b +\end{tabular}] +{\haddockbegindoc +Does something linear.\par} +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +poly :: a {\char '45}m -> b +\end{tabular}] +{\haddockbegindoc +Does something polymorphic.\par} +\end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/ref/LinearTypes/haddock.sty b/latex-test/ref/LinearTypes/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/LinearTypes/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/LinearTypes/main.tex b/latex-test/ref/LinearTypes/main.tex new file mode 100644 index 00000000..655261c3 --- /dev/null +++ b/latex-test/ref/LinearTypes/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{LinearTypes} +\end{document}
\ No newline at end of file diff --git a/latex-test/src/LinearTypes/LinearTypes.hs b/latex-test/src/LinearTypes/LinearTypes.hs new file mode 100644 index 00000000..cb4eb138 --- /dev/null +++ b/latex-test/src/LinearTypes/LinearTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LinearTypes #-} +module LinearTypes where + +-- | Does something unrestricted. +unrestricted :: a -> b +unrestricted = undefined + +-- | Does something linear. +linear :: a %1 -> b +linear = linear + +-- | Does something polymorphic. +poly :: a %m -> b +poly = poly |