From a7a5ccec3fc44f3f2deab9ba32a5b9fe95aa9f6c Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 11 Nov 2018 20:00:30 -0800 Subject: Rename 'NewOcean' theme to 'Linuwial' --- haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 10d6ab10..b1d64acd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -58,7 +58,7 @@ standardTheme :: FilePath -> IO PossibleThemes standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) --- | Default themes that are part of Haddock; added with --default-themes +-- | Default themes that are part of Haddock; added with @--built-in-themes@ -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme. -- cgit v1.2.3 From a36ab92b289b4d6b707696eef49145bc7ced4957 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 25 Nov 2018 10:32:22 -0800 Subject: More uniform handling of `forall`'s in HTML/LaTeX * don't forget to print explicit `forall`'s when there are arg docs * when printing an explicit `forall`, print all tyvars Fixes #973 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 49 ++++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 61 ++++----- html-test/ref/Bug973.html | 174 +++++++++++++++++++++++++ html-test/ref/FunArgs.html | 20 ++- html-test/ref/PatternSyns.html | 4 +- html-test/ref/Test.html | 8 +- html-test/src/Bug975.hs | 15 +++ 7 files changed, 259 insertions(+), 72 deletions(-) create mode 100644 html-test/ref/Bug973.html create mode 100644 html-test/src/Bug975.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 613c6deb..40ea916f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -458,7 +458,7 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) --- This splits up a type signature along `->` and adds docs (when they exist) +-- | This splits up a type signature along @->@ and adds docs (when they exist) -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode @@ -474,13 +474,10 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy _ tvs ltype) - = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) - <+> ppLType unicode ltype - ) ] + do_args n leader (HsForAllTy _ tvs ltype) + = do_largs n (leader <+> decltt (ppForAllPart unicode tvs)) ltype do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) + = (decltt leader, decltt (ppLContextNoArrow lctxt unicode) <+> nl) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) @@ -512,8 +509,9 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarName) +-- | Pretty-print type variables. +ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] +ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -716,15 +714,21 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then empty else ppForall) - <+> - (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Bool -- ^ unicode + -> LaTeX +ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where - ppForall = case forall of - True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - False -> empty + ppForall + | null tvs || not forall_ = empty + | otherwise = ppForAllPart unicode tvs + + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space -- | Pretty-print a constructor @@ -753,10 +757,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- First line of the constructor (no doc, no fields, single-line) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = unLoc (fromMaybe (noLoc []) cxt) forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode in case det of @@ -1010,13 +1013,17 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX +ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot + + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX ppr_mono_ty (HsForAllTy _ tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + = sep [ ppForAllPart unicode tvs , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 9df6acc0..775e0c41 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -130,8 +130,8 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) curname = getName <$> listToMaybe docnames --- This splits up a type signature along `->` and adds docs (when they exist) to --- the arguments. +-- | This splits up a type signature along @->@ and adds docs (when they exist) +-- to the arguments. -- -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. @@ -149,9 +149,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n leader' ltype - where - leader' = leader <+> ppForAll tvs unicode qual + = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -185,15 +183,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ gadtOpen = toHtml "{" - -ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html -ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ dot - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge @@ -258,10 +247,6 @@ ppTypeSig summary nms pp_ty unicode = htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocNameI -> Html @@ -814,24 +799,23 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualificati ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = unLoc (fromMaybe (noLoc []) cxt) forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args -> - ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> - ( header_ +++ ppOcc <+> char '{' + ( header_ <+> ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] @@ -840,7 +824,7 @@ ppShortConstrParts summary dataInst con unicode qual -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 ] @@ -888,28 +872,27 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = unLoc (fromMaybe (noLoc []) cxt) forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppOcc + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) , fixity ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' - RecCon _ -> header_ +++ ppOcc <+> fixity + RecCon _ -> header_ <+> ppOcc <+> fixity -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 , fixity @@ -962,17 +945,17 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -- ^ print explicit foralls - -> [Name] -- ^ type variables - -> HsContext DocNameI -- ^ context - -> Unicode -> Qualification -> Html +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification + -> Html ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml - | otherwise = forallSymbol unicode - <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " + | otherwise = ppForAllPart unicode qual tvs ppCtxt | null ctxt = noHtml diff --git a/html-test/ref/Bug973.html b/html-test/ref/Bug973.html new file mode 100644 index 00000000..97d35758 --- /dev/null +++ b/html-test/ref/Bug973.html @@ -0,0 +1,174 @@ +Bug973
Safe HaskellSafe

Bug973

Synopsis

Documentation

showRead #

Arguments

:: forall a b. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

showRead' #

Arguments

:: forall b a. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

Same as showRead, but with type variable order flipped

\ No newline at end of file diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html index bb54fa27..b40aa97c 100644 --- a/html-test/ref/FunArgs.html +++ b/html-test/ref/FunArgs.html @@ -58,7 +58,9 @@ >
:: :: forall a. Ord a:: forall a b c. a-> forall d. d=> forall c. a b c d proxy (a :: ()) b. proxy a
:: a

First argument

-> d

Result

:: forall (b :: ()). d ~ a (b :: ()) d. d ~ ()
=> a b c d

abcd

:: forall (a :: ()). proxy a

First argument

BlubType = Show x => x => BlubCtor x
  		• Show x => x => BlubCtor x
  • = C b => b => Ex1 b
  • | C a => a => Ex3 b
  		• C b => b => Ex1 bC a => a => Ex3 b a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead = read . show + +-- | Same as 'showRead', but with type variable order flipped +showRead' + :: forall b a. (Show a, Read b) + => a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead' = read . show -- cgit v1.2.3 From a6504507cb7f575dad63aa9f992cfc8d4f70c582 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Jan 2019 13:55:22 -0800 Subject: Print kinded tyvars in constructors for Hoogle (#993) Fixes #992 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++++++++-- hoogle-test/ref/Bug992/test.txt | 9 +++++++++ hoogle-test/src/Bug992/Bug992.hs | 5 +++++ 3 files changed, 22 insertions(+), 2 deletions(-) create mode 100644 hoogle-test/ref/Bug992/test.txt create mode 100644 hoogle-test/src/Bug992/Bug992.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 5f77c38c..7e2ce2f2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -266,8 +266,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat)) + as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + in apps (map noLoc (c : as)) + + tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn + tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k + tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/hoogle-test/ref/Bug992/test.txt b/hoogle-test/ref/Bug992/test.txt new file mode 100644 index 00000000..8ae145c3 --- /dev/null +++ b/hoogle-test/ref/Bug992/test.txt @@ -0,0 +1,9 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug992 +data K (m :: * -> *) +K :: K (m :: * -> *) diff --git a/hoogle-test/src/Bug992/Bug992.hs b/hoogle-test/src/Bug992/Bug992.hs new file mode 100644 index 00000000..bd772427 --- /dev/null +++ b/hoogle-test/src/Bug992/Bug992.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE KindSignatures #-} + +module Bug992 where + +data K (m :: * -> *) = K -- cgit v1.2.3 From 53997f3db71d113bdad59548e3f16adfe90c112b Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 23 Jan 2019 11:46:46 -0800 Subject: Keep forall on H98 existential data constructors (#1003) The information about whether or not there is a source-level `forall` is already available on a `ConDecl` (as `con_forall`), so we should use it instead of always assuming `False`! Fixes #1002. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- html-test/ref/PatternSyns.html | 8 ++++++-- html-test/ref/Test.html | 24 ++++++++++++++++++------ 4 files changed, 27 insertions(+), 11 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 40ea916f..a84e7e45 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -758,9 +758,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 775e0c41..bc6e2c2b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -800,9 +800,9 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of @@ -873,9 +873,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index bae4b0bd..7e10b755 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -104,7 +104,9 @@ >data BlubType = = forall x.Show x => BlubCtor
    forall x.Show x => BlubCtorEx a
    • = = forall b.C b => Ex1 b
    • | | forall b. Ex2 b
    • | | forall b.C a => Ex3
      forall b.C b => Ex1
      forall b. Ex2 b
      forall b.C a => Ex3 Date: Wed, 6 Feb 2019 01:01:41 -0800 Subject: Better identifier parsing * '(<|>)' and '`elem`' now get parsed and rendered properly as links * 'DbModule'/'DbUnitId' now properly get split apart into two links * tuple names now get parsed properly * some more small niceties... The identifier parsing code is more precise and more efficient (although to be fair: it is also longer and in its own module). On the rendering side, we need to pipe through information about backticks/parens/neither all the way through from renaming to the backends. In terms of impact: a total of 35 modules in the entirety of the bootlib + ghc lib docs change. The only "regression" is things like '\0'. These should be changed to @\\0@ (the path by which this previously worked seems accidental). --- doc/markup.rst | 9 +- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 19 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 16 +- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 28 +- haddock-api/src/Haddock/Interface/Json.hs | 5 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 58 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 4 +- haddock-api/src/Haddock/InterfaceFile.hs | 27 +- haddock-api/src/Haddock/Parser.hs | 19 +- haddock-api/src/Haddock/Types.hs | 28 +- haddock-library/haddock-library.cabal | 2 + .../src/Documentation/Haddock/Parser.hs | 63 +---- .../src/Documentation/Haddock/Parser/Identifier.hs | 186 ++++++++++++++ .../src/Documentation/Haddock/Parser/Monad.hs | 13 +- .../test/Documentation/Haddock/ParserSpec.hs | 9 +- haddock.cabal | 1 + html-test/ref/Identifiers.html | 286 +++++++++++++++++++++ html-test/ref/Test.html | 2 +- html-test/src/Identifiers.hs | 35 +++ 21 files changed, 679 insertions(+), 135 deletions(-) create mode 100644 haddock-library/src/Documentation/Haddock/Parser/Identifier.hs create mode 100644 html-test/ref/Identifiers.html create mode 100644 html-test/src/Identifiers.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/doc/markup.rst b/doc/markup.rst index 48a6f4ad..56238855 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -932,14 +932,9 @@ necessary to escape the single quote when used as an apostrophe: :: Nothing special is needed to hyperlink identifiers which contain apostrophes themselves: to hyperlink ``foo'`` one would simply type -``'foo''``. Hyperlinking operators works in exactly the same way. +``'foo''``. Hyperlinking operators works in exactly the same way. :: -Note that it is not possible to directly hyperlink an identifier in infix -form or an operator in prefix form. The next best thing to do is to wrap -the whole identifier in monospaced text and put the parentheses/backticks -outside of the identifier, but inside the link: :: - - -- | A prefix operator @('++')@ and an infix identifier @\``elem`\`@. + -- | A prefix operator @'(++)'@ and an infix identifier @'`elem`'@. Emphasis, Bold and Monospaced Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 1378c173..3e0332b5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -663,7 +663,7 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! second rdrName $ parseParas dflags Nothing str + return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9e3186e5..f581c01a 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -334,7 +334,7 @@ markupTag dflags = Markup { markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), markupModule = box (TagInline "a") . str, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d0752506..85769b13 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1106,8 +1106,8 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString +ppVerbOccName :: Wrap OccName -> LaTeX +ppVerbOccName = text . latexFilter . showWrapped occNameString ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS @@ -1115,13 +1115,12 @@ ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString +ppVerbDocName :: Wrap DocName -> LaTeX +ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName) -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc +ppVerbRdrName :: Wrap RdrName -> LaTeX +ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc) ppDocName :: DocName -> LaTeX @@ -1182,7 +1181,7 @@ parLatexMarkup ppId = Markup { markupString = \s v -> text (fixString v s), markupAppend = \l r v -> l v <> r v, markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), + markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), @@ -1239,11 +1238,11 @@ parLatexMarkup ppId = Markup { where theid = ppId_ id -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX) latexMarkup = parLatexMarkup ppVerbDocName -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX) rdrLatexMarkup = parLatexMarkup ppVerbRdrName diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 09aabc0c..1901cf05 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,12 +171,12 @@ flatten x = [x] -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' in html +++ renderMeta fmt' currPkg (metaConcat ms) where - hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta]) hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) @@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. -markupHacked :: DocMarkup id Html +markupHacked :: DocMarkup (Wrap id) Html -> Maybe Package -- this package -> Maybe String -> MDoc id @@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. @@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists) unParagraph (DocParagraph d) = d unParagraph doc = doc - fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, markupOrderedList = DocOrderedList . map unParagraph diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 574045e0..6a047747 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) + ppModule, ppModuleRef, ppIPName, linkId, Notation(..), + ppWrappedDocName, ppWrappedName, ) where @@ -24,7 +25,7 @@ import Haddock.Utils import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M -import qualified Data.List as List +import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..)) import Name @@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - +ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html +ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml + where + (mdl, occ) = unwrap x + occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation ppLDocName :: Qualification -> Notation -> Located DocName -> Html @@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName = ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name + +ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html +ppWrappedDocName qual notation insertAnchors docName = case docName of + Unadorned n -> ppDocName qual notation insertAnchors n + Parenthesized n -> ppDocName qual Prefix insertAnchors n + Backticked n -> ppDocName qual Infix insertAnchors n + +ppWrappedName :: Notation -> Wrap Name -> Html +ppWrappedName notation docName = case docName of + Unadorned n -> ppName notation n + Parenthesized n -> ppName Prefix n + Backticked n -> ppName Infix n + -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl = then ppName notation name else ppFullQualName notation mdl name RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + case stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppName notation name -- sub-module, A.B.x -> B.x diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 636d3e19..a9834fa0 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} = ] jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) +jsonDoc doc = jsonString (show (bimap showModName showName doc)) + where + showModName = showWrapped (moduleNameString . fst) + showName = showWrapped nameStableString jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 66083cf5..faf23728 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,6 +22,7 @@ module Haddock.Interface.LexParseRn import Avail import Control.Arrow import Control.Monad +import Data.Functor (($>)) import Data.List import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) @@ -95,8 +96,9 @@ rename dflags gre = rn rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier (NsRdrName ns x) -> do - let occ = rdrNameOcc x + DocIdentifier i -> do + let NsRdrName ns x = unwrap i + occ = rdrNameOcc x isValueName = isDataOcc occ || isVarOcc occ let valueNsChoices | isValueName = [x] @@ -119,7 +121,7 @@ rename dflags gre = rn case choices of -- The only way this can happen is if a value namespace was -- specified on something that cannot be a value. - [] -> invalidValue dflags x + [] -> invalidValue dflags i -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -129,14 +131,14 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags ns a + a:_ -> outOfScope dflags ns (i $> a) -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (i $> gre_name a)) -- There are multiple names available. - gres -> ambiguous dflags x gres + gres -> ambiguous dflags i gres DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -168,13 +170,13 @@ rename dflags gre = rn -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a) +outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a) outOfScope dflags ns x = - case x of - Unqual occ -> warnAndMonospace occ - Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) - Orig _ occ -> warnAndMonospace occ - Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope + case unwrap x of + Unqual occ -> warnAndMonospace (x $> occ) + Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) + Orig _ occ -> warnAndMonospace (x $> occ) + Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope where prefix = case ns of Value -> "the value " @@ -182,11 +184,11 @@ outOfScope dflags ns x = None -> "" warnAndMonospace a = do - tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it\n" ++ - " it anyway."] - pure (monospaced a) - monospaced a = DocMonospaced (DocString (showPpr dflags a)) + let a' = showWrapped (showPpr dflags) a + tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway."] + pure (monospaced a') + monospaced = DocMonospaced . DocString -- | Handle ambiguous identifiers. -- @@ -194,36 +196,42 @@ outOfScope dflags ns x = -- -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. ambiguous :: DynFlags - -> RdrName + -> Wrap NsRdrName -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ + msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ - " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + " Defaulting to the one defined " ++ defnLoc dflt -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier dflt) + pure (DocIdentifier (x $> dflt)) where isLocalName (nameSrcLoc -> RealSrcLoc {}) = True isLocalName _ = False - x_str = '\'' : showPpr dflags x ++ "'" defnLoc = showSDoc dflags . pprNameDefnLoc -- | Handle value-namespaced names that cannot be for values. -- -- Emits a warning that the value-namespace is invalid on a non-value identifier. -invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a) +invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) invalidValue dflags x = do - tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++ + tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ " namespaced as such. Did you mean to specify a type namespace\n" ++ " instead?"] - pure (DocMonospaced (DocString (showPpr dflags x))) + pure (DocMonospaced (DocString (showNsRdrName dflags x))) + +-- | Printable representation of a wrapped and namespaced name +showNsRdrName :: DynFlags -> Wrap NsRdrName -> String +showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident + where + ident = showWrapped (showPpr dflags . rdrName) + prefix = renderNs . namespace . unwrap diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 57e6d699..88238f04 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -173,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse rename) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e1d8dbe1..7645b1bb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) -binaryInterfaceVersion = 34 +binaryInterfaceVersion = 35 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -701,3 +701,28 @@ instance Binary DocName where name <- get bh return (Undocumented name) _ -> error "get DocName: Bad h" + +instance Binary n => Binary (Wrap n) where + put_ bh (Unadorned n) = do + putByte bh 0 + put_ bh n + put_ bh (Parenthesized n) = do + putByte bh 1 + put_ bh n + put_ bh (Backticked n) = do + putByte bh 2 + put_ bh n + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + return (Unadorned name) + 1 -> do + name <- get bh + return (Parenthesized name) + 2 -> do + name <- get bh + return (Backticked name) + _ -> error "get Wrap: Bad h" diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 8b7dda7c..6d5dc103 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -15,27 +15,32 @@ module Haddock.Parser ( parseParas import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types -import Haddock.Types (NsRdrName(..)) +import Haddock.Types import DynFlags ( DynFlags ) import FastString ( fsLit ) import Lexer ( mkPState, unP, ParseResult(POk) ) import Parser ( parseIdentifier ) -import RdrName ( RdrName ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName + +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName) parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod NsRdrName +parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName) parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName +parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns str0 = - let buffer = stringToStringBuffer str0 + let buffer = stringToStringBuffer str1 realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) in case unP parseIdentifier pstate of - POk _ (L _ name) -> Just (NsRdrName ns name) + POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e8da4120..cd4ac1a1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -42,7 +42,7 @@ import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt import OccName -import Outputable +import Outputable hiding ((<>)) ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -334,6 +334,26 @@ instance SetName DocName where setName name' (Documented _ mdl) = Documented name' mdl setName name' (Undocumented _) = Undocumented name' +-- | Adds extra "wrapper" information to a name. +-- +-- This is to work around the fact that most name types in GHC ('Name', 'RdrName', +-- 'OccName', ...) don't include backticks or parens. +data Wrap n + = Unadorned { unwrap :: n } -- ^ don't do anything to the name + | Parenthesized { unwrap :: n } -- ^ add parentheses around the name + | Backticked { unwrap :: n } -- ^ add backticks around the name + deriving (Show, Functor, Foldable, Traversable) + +-- | Useful for debugging +instance Outputable n => Outputable (Wrap n) where + ppr (Unadorned n) = ppr n + ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ] + ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ] + +showWrapped :: (a -> String) -> Wrap a -> String +showWrapped f (Unadorned n) = f n +showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" +showWrapped f (Backticked n) = "`" ++ f n ++ "`" ----------------------------------------------------------------------------- @@ -429,10 +449,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where type LDoc id = Located (Doc id) -type Doc id = DocH (ModuleName, OccName) id -type MDoc id = MetaDoc (ModuleName, OccName) id +type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id) +type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id) -type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a instance (NFData a, NFData mod) => NFData (DocH mod a) where diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b24db5d4..5475d61b 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -49,6 +49,7 @@ library other-modules: Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier test-suite spec import: lib-defaults @@ -70,6 +71,7 @@ test-suite spec Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.10.0 diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index e9b1c496..36c8bb5b 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -27,8 +27,7 @@ module Documentation.Haddock.Parser ( import Control.Applicative import Control.Arrow (first) import Control.Monad -import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) -import Data.Foldable (asum) +import Data.Char (chr, isUpper, isAlpha, isSpace) import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -37,6 +36,7 @@ import Documentation.Haddock.Doc import Documentation.Haddock.Markup ( markup, plainMarkup ) import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util +import Documentation.Haddock.Parser.Identifier import Documentation.Haddock.Types import Prelude hiding (takeWhile) import qualified Prelude as P @@ -47,37 +47,10 @@ import Text.Parsec (try) import qualified Data.Text as T import Data.Text (Text) -#if MIN_VERSION_base(4,9,0) -import Text.Read.Lex (isSymbolChar) -#else -import Data.Char (GeneralCategory (..), - generalCategory) -#endif -- $setup -- >>> :set -XOverloadedStrings -#if !MIN_VERSION_base(4,9,0) --- inlined from base-4.10.0.0 -isSymbolChar :: Char -> Bool -isSymbolChar c = not (isPuncChar c) && case generalCategory c of - MathSymbol -> True - CurrencySymbol -> True - ModifierSymbol -> True - OtherSymbol -> True - DashPunctuation -> True - OtherPunctuation -> c `notElem` ("'\"" :: String) - ConnectorPunctuation -> c /= '_' - _ -> False - where - -- | The @special@ character class as defined in the Haskell Report. - isPuncChar :: Char -> Bool - isPuncChar = (`elem` (",;()[]{}`" :: String)) -#endif - --- | Identifier string surrounded with opening and closing quotes/backticks. -data Identifier = Identifier !Namespace !Char String !Char - -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String @@ -838,34 +811,6 @@ autoUrl = mkLink <$> url mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing - --- | Parses strings between identifier delimiters. Consumes all input that it --- deems to be valid in an identifier. Note that it simply blindly consumes --- characters and does no actual validation itself. -parseValid :: Parser String -parseValid = p some - where - idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') - - p p' = do - vs <- p' idChar - c <- peekChar' - case c of - '`' -> return vs - '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] - _ -> fail "outofvalid" - --- | Parses identifiers with help of 'parseValid'. Asks GHC for --- 'String' from the string it deems valid. +-- | Parses identifiers with help of 'parseValid'. identifier :: Parser (DocH mod Identifier) -identifier = do - ns <- asum [ Value <$ Parsec.char 'v' - , Type <$ Parsec.char 't' - , pure None - ] - o <- idDelim - vid <- parseValid - e <- idDelim - return $ DocIdentifier (Identifier ns o vid e) - where - idDelim = Parsec.oneOf "'`" +identifier = DocIdentifier <$> parseValid diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs new file mode 100644 index 00000000..7bc98b62 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Documentation.Haddock.Parser.Identifier +-- Copyright : (c) Alec Theriault 2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Functionality for parsing identifiers and operators + +module Documentation.Haddock.Parser.Identifier ( + Identifier(..), + parseValid, +) where + +import Documentation.Haddock.Types ( Namespace(..) ) +import Documentation.Haddock.Parser.Monad +import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Char (isAlpha, isAlphaNum) +import Control.Monad (guard) +import Data.Functor (($>)) +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif + +import Data.Maybe + +-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. +data Identifier = Identifier !Namespace !Char String !Char + deriving (Show, Eq) + +parseValid :: Parser Identifier +parseValid = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + + case takeIdentifier inp of + Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier" + Just (ns, op, ident, cl, inp') -> + let posOp = updatePosChar pos op + posIdent = T.foldl updatePosChar posOp ident + posCl = updatePosChar posIdent cl + s' = s{ stateInput = inp', statePos = posCl } + in setParserState s' $> Identifier ns op (T.unpack ident) cl + + +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> c `notElem` "'\"" + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + +-- | Try to parse a delimited identifier off the front of the given input. +-- +-- This tries to match as many valid Haskell identifiers/operators as possible, +-- to the point of sometimes accepting invalid things (ex: keywords). Some +-- considerations: +-- +-- - operators and identifiers can have module qualifications +-- - operators can be wrapped in parens (for prefix) +-- - identifiers can be wrapped in backticks (for infix) +-- - delimiters are backticks or regular ticks +-- - since regular ticks are also valid in identifiers, we opt for the +-- longest successful parse +-- +-- This function should make /O(1)/ allocations +takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text) +takeIdentifier input = listToMaybe $ do + + -- Optional namespace + let (ns, input') = case T.uncons input of + Just ('v', i) -> (Value, i) + Just ('t', i) -> (Type, i) + _ -> (None, input) + + -- Opening tick + (op, input'') <- maybeToList (T.uncons input') + guard (op == '\'' || op == '`') + + -- Identifier/operator + (ident, input''') <- wrapped input'' + + -- Closing tick + (cl, input'''') <- maybeToList (T.uncons input''') + guard (cl == '\'' || cl == '`') + + pure (ns, op, ident, cl, input'''') + + where + + -- | Parse out a wrapped, possibly qualified, operator or identifier + wrapped t = do + (c, t' ) <- maybeToList (T.uncons t) + -- Tuples + case c of + '(' | Just (c', _) <- T.uncons t' + , c' == ',' || c' == ')' + -> do let (commas, t'') = T.span (== ',') t' + (')', t''') <- maybeToList (T.uncons t'') + pure (T.take (T.length commas + 2) t, t''') + + -- Parenthesized + '(' -> do (n, t'' ) <- general False 0 [] t' + (')', t''') <- maybeToList (T.uncons t'') + pure (T.take (n + 2) t, t''') + + -- Backticked + '`' -> do (n, t'' ) <- general False 0 [] t' + ('`', t''') <- maybeToList (T.uncons t'') + pure (T.take (n + 2) t, t''') + + -- Unadorned + _ -> do (n, t'' ) <- general False 0 [] t + pure (T.take n t, t'') + + -- | Parse out a possibly qualified operator or identifier + general :: Bool -- ^ refuse inputs starting with operators + -> Int -- ^ total characters \"consumed\" so far + -> [(Int, Text)] -- ^ accumulated results + -> Text -- ^ current input + -> [(Int, Text)] -- ^ total characters parsed & what remains + general !identOnly !i acc t + -- Starts with an identifier (either just an identifier, or a module qual) + | Just (n, rest) <- identLike t + = if T.null rest + then acc + else case T.head rest of + '`' -> (n + i, rest) : acc + ')' -> (n + i, rest) : acc + '.' -> general False (n + i + 1) acc (T.tail rest) + '\'' -> let (m, rest') = quotes rest + in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest') + _ -> acc + + -- An operator + | Just (n, rest) <- optr t + , not identOnly + = (n + i, rest) : acc + + -- Anything else + | otherwise + = acc + + -- | Parse an identifier off the front of the input + identLike t + | T.null t = Nothing + | isAlpha (T.head t) || '_' == T.head t + = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t + !(octos, rest') = T.span (== '#') rest + in Just (T.length idt + T.length octos, rest') + | otherwise = Nothing + + -- | Parse all but the last quote off the front of the input + -- PRECONDITION: T.head t == '\'' + quotes :: Text -> (Int, Text) + quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1 + in (n, T.drop n t) + + -- | Parse an operator off the front of the input + optr t = let !(op, rest) = T.span isSymbolChar t + in if T.null op then Nothing else Just (T.length op, rest) diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 8f5bd217..fa46f536 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -4,6 +4,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Documentation.Haddock.Parser.Monad +-- Copyright : (c) Alec Theriault 2018-2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Defines the Parsec monad over which all parsing is done and also provides +-- more efficient versions of the usual parsec combinator functions (but +-- specialized to 'Text'). module Documentation.Haddock.Parser.Monad where @@ -96,7 +108,6 @@ takeWhile f = do s' = s{ stateInput = inp', statePos = pos' } setParserState s' $> t - -- | Like 'takeWhile', but fails if no characters matched. -- -- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient. diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index e186a5cf..bc40a0a2 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -112,7 +112,7 @@ spec = do "``" `shouldParseTo` "``" it "can parse an identifier in infix notation enclosed within backticks" $ do - "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`" + "``infix``" `shouldParseTo` DocIdentifier "`infix`" it "can parse identifiers containing a single quote" $ do "'don't'" `shouldParseTo` DocIdentifier "don't" @@ -138,6 +138,13 @@ spec = do it "can parse type-namespaced identifiers" $ do "t'foo'" `shouldParseTo` DocIdentifier "foo" + it "can parse parenthesized operators and backticked identifiers" $ do + "'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)" + "'`elem`'" `shouldParseTo` DocIdentifier "`elem`" + + it "can properly figure out the end of identifiers" $ do + "'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" diff --git a/haddock.cabal b/haddock.cabal index 2b8ee6ff..91a5ea3d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -89,6 +89,7 @@ executable haddock other-modules: Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier Documentation.Haddock.Types Documentation.Haddock.Doc Documentation.Haddock.Parser.Util diff --git a/html-test/ref/Identifiers.html b/html-test/ref/Identifiers.html new file mode 100644 index 00000000..1a0a18a5 --- /dev/null +++ b/html-test/ref/Identifiers.html @@ -0,0 +1,286 @@ +Identifiers
      Safe HaskellSafe

      Identifiers

      Synopsis

      Documentation

      data Id #

      Constructors

      Id 

      data a :* b #

      Constructors

      a :* b 

      foo :: () #

      diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html index b76622e7..aefc4d14 100644 --- a/html-test/ref/Test.html +++ b/html-test/ref/Test.html @@ -2364,7 +2364,7 @@ is at the beginning of the line).f' - but f' doesn't get link'd 'f\''

      Date: Fri, 8 Mar 2019 13:23:37 -0800 Subject: Better support for default methods in classes * default methods now get rendered differently * default associated types get rendered * fix a forgotten `s/TypeSig/ClassOpSig/` refactor in LaTeX backend * LaTeX backend now renders default method signatures NB: there is still no way to document default class members and the NB: LaTeX backend still crashes on associated types --- CHANGES.md | 3 + haddock-api/src/Haddock/Backends/LaTeX.hs | 47 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 99 +++++++---- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 + haddock-api/src/Haddock/Types.hs | 3 + html-test/ref/DefaultAssociatedTypes.html | 158 ++++++++++++++++++ html-test/ref/DefaultSignatures.html | 182 +++++++++++++++++++++ html-test/src/DefaultAssociatedTypes.hs | 14 ++ html-test/src/DefaultSignatures.hs | 19 +++ .../ref/DefaultSignatures/DefaultSignatures.tex | 41 +++++ latex-test/ref/DefaultSignatures/haddock.sty | 57 +++++++ latex-test/ref/DefaultSignatures/main.tex | 11 ++ .../src/DefaultSignatures/DefaultSignatures.hs | 19 +++ 13 files changed, 606 insertions(+), 51 deletions(-) create mode 100644 html-test/ref/DefaultAssociatedTypes.html create mode 100644 html-test/ref/DefaultSignatures.html create mode 100644 html-test/src/DefaultAssociatedTypes.hs create mode 100644 html-test/src/DefaultSignatures.hs create mode 100644 latex-test/ref/DefaultSignatures/DefaultSignatures.tex create mode 100644 latex-test/ref/DefaultSignatures/haddock.sty create mode 100644 latex-test/ref/DefaultSignatures/main.tex create mode 100644 latex-test/src/DefaultSignatures/DefaultSignatures.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/CHANGES.md b/CHANGES.md index 15a88221..bd4317bf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -23,6 +23,9 @@ * `--show-interface` now outputs to stdout (instead of stderr) + * Render associated type defaults and also improve rendering of + default method signatures + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 119bbc01..d2baefac 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -295,7 +295,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -307,7 +307,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig Nothing doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -414,17 +414,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames + lead = maybe id (<+>) leader -- | Pretty-print a pattern synonym ppLPatSig :: DocForDecl DocName -- ^ documentation @@ -433,15 +439,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigType ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. @@ -585,6 +583,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated types, associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -610,13 +609,15 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + vcat [ ppFunSig leader doc names (hsSigType typ) unicode + | L _ (ClassOpSig _ is_def lnames typ) <- lsigs + , let doc | is_def = noDocForDecl + | otherwise = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. instancesBit = ppDocInstances unicode instances diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f2cab635..56a79d57 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,6 +36,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula @@ -75,14 +76,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -218,7 +219,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -496,7 +497,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -517,8 +518,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs + , tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d @@ -535,28 +537,68 @@ ppClassDecl summary links instances fixities loc d subdocs -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - nm = tcdName decl - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = ppDefaultAssocTy name <$> lookupDAT name + ] + + -- Default associated types + ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl + splice unicode pkg qual + where + synDecl = SynDecl { tcdSExt = noExt + , tcdLName = noLoc n + , tcdTyVars = vs + , tcdFixity = GHC.Prefix + , tcdRhs = t } + + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ, doc)) + | L _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }) <- atsDefs + , let doc = noDocForDecl -- TODO: get docs for associated type defaults + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ) + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] (hsSigType t) [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = noDocForDecl -- TODO: get docs for method defaults + nameStr = getOccString name + ] + -- Minimal complete definition minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == @@ -565,7 +607,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -580,6 +622,7 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) + -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 25d8b07a..4535b897 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout ( subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -259,6 +260,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock + subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index cd4ac1a1..a72247e6 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -355,6 +355,9 @@ showWrapped f (Unadorned n) = f n showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" showWrapped f (Backticked n) = "`" ++ f n ++ "`" +instance HasOccName DocName where + + occName = occName . getName ----------------------------------------------------------------------------- -- * Instances diff --git a/html-test/ref/DefaultAssociatedTypes.html b/html-test/ref/DefaultAssociatedTypes.html new file mode 100644 index 00000000..d456815f --- /dev/null +++ b/html-test/ref/DefaultAssociatedTypes.html @@ -0,0 +1,158 @@ +DefaultAssociatedTypes
      Safe HaskellSafe

      DefaultAssociatedTypes

      Synopsis

      Documentation

      class Foo a where #

      Documentation for Foo.

      Associated Types

      type Qux a :: * #

      Doc for Qux

      type Qux a = [a] #

      Methods

      bar :: a -> String #

      Documentation for bar and baz.

      baz :: a -> String #

      Documentation for bar and baz.

      \ No newline at end of file diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 index 00000000..4bf261f7 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,182 @@ +DefaultSignatures
      Safe HaskellSafe

      DefaultSignatures

      Synopsis

      Documentation

      class Foo a where #

      Documentation for Foo.

      Minimal complete definition

      baz

      Methods

      bar :: a -> String #

      Documentation for bar and baz.

      default bar :: Show a => a -> String #

      baz :: a -> String #

      Documentation for bar and baz.

      baz' :: String -> a #

      Documentation for baz'.

      default baz' :: Read a => String -> a #

      \ No newline at end of file diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs new file mode 100644 index 00000000..6ad197d3 --- /dev/null +++ b/html-test/src/DefaultAssociatedTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DefaultSignatures, TypeFamilies #-} + +module DefaultAssociatedTypes where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Doc for Qux + type Qux a :: * + + -- | Doc for default Qux + type Qux a = [a] diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs new file mode 100644 index 00000000..52d68a96 --- /dev/null +++ b/html-test/src/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex new file mode 100644 index 00000000..4dbcda49 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{DefaultSignatures} +\label{module:DefaultSignatures} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module DefaultSignatures ( + Foo(baz', baz, bar) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +class\ Foo\ a\ where +\end{tabular}]\haddockbegindoc +Documentation for Foo.\par + +\haddockpremethods{}\emph{Methods} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +bar,\ baz\ ::\ a\ ->\ String +\end{tabular}]\haddockbegindoc +Documentation for bar and baz.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +baz'\ ::\ String\ ->\ a +\end{tabular}]\haddockbegindoc +Documentation for baz'.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a +\end{tabular}] +\end{haddockdesc} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/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/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex new file mode 100644 index 00000000..d30eb008 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{DefaultSignatures} +\end{document} \ No newline at end of file diff --git a/latex-test/src/DefaultSignatures/DefaultSignatures.hs b/latex-test/src/DefaultSignatures/DefaultSignatures.hs new file mode 100644 index 00000000..52d68a96 --- /dev/null +++ b/latex-test/src/DefaultSignatures/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read -- cgit v1.2.3 From 747dfc712bd516b76342f2e17dada7a64d43c778 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 9 Sep 2018 13:53:32 -0700 Subject: Avoid multi-line `emph` in LaTeX backend `markupWarning` often processes inputs which span across paragraphs. Unfortunately, LaTeX's `emph` is not made to handle this (and will crash). Fixes #936. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- latex-test/ref/Deprecated/Deprecated.tex | 17 +++++++++ latex-test/ref/Deprecated/haddock.sty | 57 +++++++++++++++++++++++++++++++ latex-test/ref/Deprecated/main.tex | 11 ++++++ latex-test/src/Deprecated/Deprecated.hs | 7 ++++ 5 files changed, 93 insertions(+), 1 deletion(-) create mode 100644 latex-test/ref/Deprecated/Deprecated.tex create mode 100644 latex-test/ref/Deprecated/haddock.sty create mode 100644 latex-test/ref/Deprecated/main.tex create mode 100644 latex-test/src/Deprecated/Deprecated.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d2baefac..1cc17dab 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1191,7 +1191,7 @@ parLatexMarkup ppId = Markup { markupIdentifier = markupId ppId, markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> emph (p v), + markupWarning = \p v -> p v, markupEmphasis = \p v -> emph (p v), markupBold = \p v -> bold (p v), markupMonospaced = \p _ -> tt (p Mono), diff --git a/latex-test/ref/Deprecated/Deprecated.tex b/latex-test/ref/Deprecated/Deprecated.tex new file mode 100644 index 00000000..fa8fc20a --- /dev/null +++ b/latex-test/ref/Deprecated/Deprecated.tex @@ -0,0 +1,17 @@ +\haddockmoduleheading{Deprecated} +\label{module:Deprecated} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module Deprecated ( + deprecated + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +deprecated\ ::\ Int +\end{tabular}]\haddockbegindoc +Deprecated: Don't use this\par +Docs for something deprecated\par + +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/Deprecated/haddock.sty b/latex-test/ref/Deprecated/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/Deprecated/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/Deprecated/main.tex b/latex-test/ref/Deprecated/main.tex new file mode 100644 index 00000000..76def1cd --- /dev/null +++ b/latex-test/ref/Deprecated/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{Deprecated} +\end{document} \ No newline at end of file diff --git a/latex-test/src/Deprecated/Deprecated.hs b/latex-test/src/Deprecated/Deprecated.hs new file mode 100644 index 00000000..aecec94e --- /dev/null +++ b/latex-test/src/Deprecated/Deprecated.hs @@ -0,0 +1,7 @@ +module Deprecated where + +-- | Docs for something deprecated +deprecated :: Int +deprecated = 1 + +{-# DEPRECATED deprecated "Don't use this" #-} -- cgit v1.2.3 From ae23b4f25a972620686617b5aab5375d5046b1c9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 9 Sep 2018 14:25:57 -0700 Subject: Many LaTeX backend fixes After this commit, we can run with `--latex` on all boot libraries without crashing (although the generated LaTeX still fails to compile in a handful of larger packages like `ghc` and `base`). * Add newlines after all block elements in LaTeX. This is important to prevent the final output from being more an more indented. See the `latext-test/src/Example` test case for a sample of this. * Support associated types in class declarations (but not yet defaults) * Several small issues for producing compiling LaTeX; - avoid empy `\haddockbeginargs` lists (ex: `type family Any`) - properly escape identifiers depending on context (ex: `Int#`) - add `vbox` around `itemize`/`enumerate` (so they can be in tables) * Several spacing fixes: - limit the width of `Pretty`-arranged monospaced code - cut out extra space characters in export lists - only escape spaces if there are _multiple_ spaces - allow type signatures to be multiline (even without docs) * Remove uninteresting and repetitive `main.tex`/`haddock.sty` files from `latex-test` test reference output. Fixes #935, #929 (LaTeX docs for `text` build & compile) Fixes #727, #930 (I think both are really about type families...) --- CHANGES.md | 3 + haddock-api/src/Haddock/Backends/LaTeX.hs | 216 +++++++++++---------- latex-test/Main.hs | 4 +- latex-test/ref/ConstructorArgs/ConstructorArgs.tex | 34 ++-- latex-test/ref/ConstructorArgs/haddock.sty | 57 ------ latex-test/ref/ConstructorArgs/main.tex | 11 -- .../ref/DefaultSignatures/DefaultSignatures.tex | 28 +-- latex-test/ref/DefaultSignatures/haddock.sty | 57 ------ latex-test/ref/DefaultSignatures/main.tex | 11 -- latex-test/ref/Deprecated/Deprecated.tex | 8 +- latex-test/ref/Deprecated/haddock.sty | 57 ------ latex-test/ref/Deprecated/main.tex | 11 -- latex-test/ref/Example/Example.tex | 30 +++ .../GadtConstructorArgs/GadtConstructorArgs.tex | 15 +- latex-test/ref/GadtConstructorArgs/haddock.sty | 57 ------ latex-test/ref/GadtConstructorArgs/main.tex | 11 -- .../NamespacedIdentifier/NamespacedIdentifiers.tex | 26 ++- latex-test/ref/NamespacedIdentifier/haddock.sty | 57 ------ latex-test/ref/NamespacedIdentifier/main.tex | 11 -- latex-test/ref/Simple/Simple.tex | 8 +- latex-test/ref/Simple/haddock.sty | 57 ------ latex-test/ref/Simple/main.tex | 11 -- latex-test/ref/TypeFamilies3/TypeFamilies3.tex | 32 +-- latex-test/ref/TypeFamilies3/haddock.sty | 57 ------ latex-test/ref/TypeFamilies3/main.tex | 11 -- latex-test/ref/UnboxedStuff/UnboxedStuff.tex | 26 +-- latex-test/ref/UnboxedStuff/haddock.sty | 57 ------ latex-test/ref/UnboxedStuff/main.tex | 11 -- latex-test/src/Example/Example.hs | 11 ++ 29 files changed, 253 insertions(+), 732 deletions(-) delete mode 100644 latex-test/ref/ConstructorArgs/haddock.sty delete mode 100644 latex-test/ref/ConstructorArgs/main.tex delete mode 100644 latex-test/ref/DefaultSignatures/haddock.sty delete mode 100644 latex-test/ref/DefaultSignatures/main.tex delete mode 100644 latex-test/ref/Deprecated/haddock.sty delete mode 100644 latex-test/ref/Deprecated/main.tex create mode 100644 latex-test/ref/Example/Example.tex delete mode 100644 latex-test/ref/GadtConstructorArgs/haddock.sty delete mode 100644 latex-test/ref/GadtConstructorArgs/main.tex delete mode 100644 latex-test/ref/NamespacedIdentifier/haddock.sty delete mode 100644 latex-test/ref/NamespacedIdentifier/main.tex delete mode 100644 latex-test/ref/Simple/haddock.sty delete mode 100644 latex-test/ref/Simple/main.tex delete mode 100644 latex-test/ref/TypeFamilies3/haddock.sty delete mode 100644 latex-test/ref/TypeFamilies3/main.tex delete mode 100644 latex-test/ref/UnboxedStuff/haddock.sty delete mode 100644 latex-test/ref/UnboxedStuff/main.tex create mode 100644 latex-test/src/Example/Example.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/CHANGES.md b/CHANGES.md index bd4317bf..a6d96fed 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -26,6 +26,9 @@ * Render associated type defaults and also improve rendering of default method signatures + * Many fixes to the LaTeX backend, mostly focused on not crashing + as well as generating LaTeX source that compiles + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1cc17dab..cc096a7a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -103,6 +103,10 @@ haddockSty = "haddock.sty" type LaTeX = Pretty.Doc +-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 +-- often overflows the line). +latex2String :: LaTeX -> String +latex2String = fullRender PageMode 90 1 txtPrinter "" ppLaTeXTop :: String @@ -156,7 +160,7 @@ ppLaTeXModule _title odir iface = do text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ + text " " <> fsep (punctuate (char ',') $ map exportListItem $ filter forSummary exports), text " ) where" @@ -171,7 +175,7 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeUtf8File (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) + writeUtf8File (odir moduleLaTeXFile mdl) (show tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -287,7 +291,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now @@ -317,13 +321,14 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" ------------------------------------------------------------------------------- -- | Pretty-print a data\/type family declaration -ppFamDecl :: Documentation DocName -- ^ this decl's docs +ppFamDecl :: Bool -- ^ is the family associated? + -> Documentation DocName -- ^ this decl's docs -> [DocInstance DocNameI] -- ^ relevant instances -> TyClDecl DocNameI -- ^ family to print -> Bool -- ^ unicode -> LaTeX -ppFamDecl doc instances decl unicode = - declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) +ppFamDecl associated doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -335,6 +340,7 @@ ppFamDecl doc instances decl unicode = familyEqns | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + , not (null eqns) = Just (text "\\haddockbeginargs" $$ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ text "\\end{tabulary}\\par") @@ -356,22 +362,26 @@ ppFamDecl doc instances decl unicode = -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print - -> Bool -- ^ unicode - -> LaTeX -ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX +ppFamHeader (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity }) - unicode = - leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + unicode associated = + famly leader <+> famName <+> famSig <+> injAnn where leader = case info of OpenTypeFamily -> keyword "type" ClosedTypeFamily _ -> keyword "type" DataFamily -> keyword "data" + famly | associated = id + | otherwise = (<+> keyword "family") + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) famSig = case result of @@ -475,11 +485,15 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n (leader <+> decltt (ppForAllPart unicode tvs)) ltype + do_args _n leader (HsForAllTy _ tvs ltype) + = [ ( decltt leader + , decltt (ppForAllPart unicode tvs) + <+> ppLType unicode ltype + ) ] do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, decltt (ppLContextNoArrow lctxt unicode) <+> nl) - : do_largs n (darrow unicode) ltype + = ( decltt leader + , decltt (ppLContextNoArrow lctxt unicode) <+> nl + ) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) @@ -498,9 +512,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. - gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," - gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" - gadtOpen = text "\\{" + gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ',' + gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}' + gadtOpen = char '{' ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -512,7 +526,7 @@ ppTypeSig nms ty unicode = -- | Pretty-print type variables. ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs +ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -523,10 +537,9 @@ declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = text "\\begin{haddockdesc}" $$ text "\\item[\\begin{tabular}{@{}l}" $$ - text (latexMonoFilter (show decl)) $$ - text "\\end{tabular}]" <> - (if isNothing doc then empty else text "\\haddockbegindoc") $$ - maybe empty id doc $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" $$ + maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ text "\\end{haddockdesc}" @@ -537,9 +550,9 @@ multiDecl :: [LaTeX] -> LaTeX multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" | decl <- decls ] $$ text "\\end{haddockdesc}" @@ -583,7 +596,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) --- TODO: associated types, associated type defaults, docs on default methods +-- TODO: associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -604,8 +617,16 @@ ppClassDecl instances doc subdocs body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" + | otherwise = Just (atTable $$ methodTable) + + atTable = + text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ + vcat [ ppFamDecl True (fst doc) [] (FamDecl noExt decl) True + | L _ decl <- ats + , let name = unL . fdLName $ decl + doc = lookupAnySubdoc name subdocs + ] + methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ @@ -636,6 +657,7 @@ ppDocInstances unicode (i : rest) isUndocdInstance :: DocInstance a -> Maybe (InstHead a) isUndocdInstance (i,Nothing,_,_) = Just i +isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside @@ -1001,7 +1023,7 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode -ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode @@ -1014,7 +1036,7 @@ ppLHsTypeArg _ (HsArgPar _) = text "" ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" ppLKind :: Bool -> LHsKind DocNameI -> LaTeX @@ -1080,7 +1102,7 @@ ppr_mono_ty (HsParTy _ ty) unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy _) _ = text "\\_" +ppr_mono_ty (HsWildCardTy _) _ = char '_' ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1114,27 +1136,16 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: Wrap OccName -> LaTeX -ppVerbOccName = text . latexFilter . showWrapped occNameString - ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString -ppVerbDocName :: Wrap DocName -> LaTeX -ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName) - - -ppVerbRdrName :: Wrap RdrName -> LaTeX -ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc) - ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName - ppLDocName :: Located DocName -> LaTeX ppLDocName (L _ d) = ppDocName d @@ -1172,9 +1183,10 @@ latexMunge c s = c : s latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s +latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s +latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- @@ -1182,34 +1194,40 @@ latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- -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), - markupAppend = \l r v -> l v <> r v, - markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), - markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> p v, - markupEmphasis = \p v -> emph (p v), - markupBold = \p v -> bold (p v), - markupMonospaced = \p _ -> tt (p Mono), - markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \p _ -> markupPic p, - markupMathInline = \p _ -> markupMathInline p, - markupMathDisplay = \p _ -> markupMathDisplay p, - markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", - markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), - markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l), - markupAName = \_ _ -> empty, - markupProperty = \p _ -> quote $ verb $ text p, - markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p), - markupTable = \(Table h b) p -> table h b p +latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX) +latexMarkup = Markup + { markupParagraph = \p v -> blockElem (p v (text "\\par")) + , markupEmpty = \_ -> id + , markupString = \s v -> inlineElem (text (fixString v s)) + , 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))) + , markupWarning = \p v -> p v + , markupEmphasis = \p v -> inlineElem (emph (p v empty)) + , markupBold = \p v -> inlineElem (bold (p v empty)) + , markupMonospaced = \p v -> inlineElem (markupMonospace p v) + , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p)) + , markupPic = \p _ -> inlineElem (markupPic p) + , markupMathInline = \p _ -> inlineElem (markupMathInline p) + , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) + , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) + , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) + , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) + , markupAName = \_ _ -> id -- TODO + , markupProperty = \p _ -> blockElem (quote (verb (text p))) + , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e))) + , markupHeader = \(Header l h) p -> blockElem (header l (h p empty)) + , markupTable = \(Table h b) p -> blockElem (table h b p) } where + blockElem :: LaTeX -> LaTeX -> LaTeX + blockElem = ($$) + + inlineElem :: LaTeX -> LaTeX -> LaTeX + inlineElem = (<>) + header 1 d = text "\\section*" <> braces d header 2 d = text "\\subsection*" <> braces d header l d @@ -1222,6 +1240,9 @@ parLatexMarkup ppId = Markup { fixString Verb s = s fixString Mono s = latexMonoFilter s + markupMonospace p Verb = p Verb empty + markupMonospace p _ = tt (p Mono empty) + markupLink url mLabel = case mLabel of Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) @@ -1238,35 +1259,28 @@ parLatexMarkup ppId = Markup { markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" - markupId ppId_ id v = + markupId v wrappedOcc = case v of - Verb -> theid - Mono -> theid - Plain -> text "\\haddockid" <> braces theid - where theid = ppId_ id - - -latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName - - -rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName - + Verb -> text i + Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i) + Plain -> text "\\haddockid" <> braces (text . latexFilter $ i) + where i = showWrapped occNameString wrappedOcc docToLaTeX :: Doc DocName -> LaTeX -docToLaTeX doc = markup latexMarkup doc Plain - +docToLaTeX doc = markup latexMarkup doc Plain empty documentationToLaTeX :: Documentation DocName -> Maybe LaTeX documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX -rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain +rdrDocToLaTeX doc = markup latexMarkup doc Plain empty -data StringContext = Plain | Verb | Mono +data StringContext + = Plain -- ^ all special characters have to be escape + | Mono -- ^ on top of special characters, escape space chraacters + | Verb -- ^ don't escape anything latexStripTrailingWhitespace :: Doc a -> Doc a @@ -1291,23 +1305,23 @@ latexStripTrailingWhitespace other = other itemizedList :: [LaTeX] -> LaTeX itemizedList items = - text "\\begin{itemize}" $$ + text "\\vbox{\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" + text "\\end{itemize}}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = - text "\\begin{enumerate}" $$ + text "\\vbox{\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" + text "\\end{enumerate}}" descriptionList :: [(LaTeX,LaTeX)] -> LaTeX descriptionList items = - text "\\begin{description}" $$ - vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ - text "\\end{description}" + text "\\vbox{\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ + text "\\end{description}}" tt :: LaTeX -> LaTeX @@ -1315,8 +1329,8 @@ tt ltx = text "\\haddocktt" <> braces ltx decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - +decltt ltx = text "\\haddockdecltt" <> braces (text filtered) + where filtered = latexMonoFilter (latex2String ltx) emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx @@ -1324,6 +1338,12 @@ emph ltx = text "\\emph" <> braces ltx bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx +-- TODO: @verbatim@ is too much since +-- +-- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX +-- representing that markup gets printed verbatim +-- * Verbatim environments are not supported everywhere (example: not nested +-- inside a @tabulary@ environment) verb :: LaTeX -> LaTeX verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" -- NB. swallow a trailing \n in the verbatim text by appending the diff --git a/latex-test/Main.hs b/latex-test/Main.hs index 8d2a4922..17ae8ae8 100755 --- a/latex-test/Main.hs +++ b/latex-test/Main.hs @@ -19,7 +19,9 @@ checkConfig = CheckConfig dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = (`elem` ["haddock.sty", "main.tex"]) . takeFileName + } main :: IO () diff --git a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex index 44304f47..053d2e41 100644 --- a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex +++ b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex @@ -3,15 +3,16 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module ConstructorArgs ( - Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), pattern Bo, - pattern Bo' + Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), + pattern Bo, pattern Bo' ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Foo -\end{tabular}]\haddockbegindoc +data Foo +\end{tabular}] +{\haddockbegindoc \enspace \emph{Constructors}\par \haddockbeginconstrs \haddockdecltt{=} & \haddockdecltt{Rec} & doc on a record \\ @@ -25,12 +26,13 @@ data\ Foo \haddockdecltt{|} & \haddockdecltt{(:*)} & doc on the \haddockid{:*} constructor \\ & \qquad \haddockdecltt{Int} & doc on the \haddockid{Int} field of the \haddockid{:*} constructor \\ & \qquad \haddockdecltt{String} & doc on the \haddockid{String} field of the \haddockid{:*} constructor \\ -\end{tabulary}\par +\end{tabulary}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Boo\ where -\end{tabular}]\haddockbegindoc +data Boo where +\end{tabular}] +{\haddockbegindoc \enspace \emph{Constructors}\par \haddockbeginconstrs & \haddockdecltt{Foo} & Info about a \haddockid{Foo} \\ @@ -46,24 +48,24 @@ data\ Boo\ where & \qquad \haddockdecltt{->} \enspace \haddockdecltt{String} & a \haddockid{String} \\ & \qquad \haddockdecltt{->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ & \haddockdecltt{pattern Fo' :: Boo} & Bundled and no argument docs \\ -\end{tabulary}\par +\end{tabulary}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -pattern\ Bo -\end{tabular}]\haddockbegindoc +pattern Bo +\end{tabular}] +{\haddockbegindoc \haddockbeginargs \haddockdecltt{::} & \haddockdecltt{Int} & an \haddockid{Int} \\ \haddockdecltt{->} & \haddockdecltt{String} & a \haddockid{String} \\ \haddockdecltt{->} & \haddockdecltt{Boo} & a \haddockid{Boo} pattern \\ \end{tabulary}\par -Info about not-bundled \haddockid{Bo}\par - +Info about not-bundled \haddockid{Bo}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -pattern\ Bo'\ ::\ Int\ ->\ String\ ->\ Boo -\end{tabular}]\haddockbegindoc -Not bunded and no argument docs\par - +pattern Bo' :: Int -> String -> Boo +\end{tabular}] +{\haddockbegindoc +Not bunded and no argument docs\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/ConstructorArgs/haddock.sty b/latex-test/ref/ConstructorArgs/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/ConstructorArgs/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/ConstructorArgs/main.tex b/latex-test/ref/ConstructorArgs/main.tex deleted file mode 100644 index 80f639c5..00000000 --- a/latex-test/ref/ConstructorArgs/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{ConstructorArgs} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex index 4dbcda49..162f5014 100644 --- a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -9,33 +9,33 @@ module DefaultSignatures ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -class\ Foo\ a\ where -\end{tabular}]\haddockbegindoc +class Foo a where +\end{tabular}] +{\haddockbegindoc Documentation for Foo.\par - \haddockpremethods{}\emph{Methods} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -bar,\ baz\ ::\ a\ ->\ String -\end{tabular}]\haddockbegindoc -Documentation for bar and baz.\par - +bar, baz :: a -> String +\end{tabular}] +{\haddockbegindoc +Documentation for bar and baz.\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String +default bar :: Show a => a -> String \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -baz'\ ::\ String\ ->\ a -\end{tabular}]\haddockbegindoc -Documentation for baz'.\par - +baz' :: String -> a +\end{tabular}] +{\haddockbegindoc +Documentation for baz'.\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a +default baz' :: Read a => String -> a \end{tabular}] -\end{haddockdesc} +\end{haddockdesc}} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/DefaultSignatures/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex deleted file mode 100644 index d30eb008..00000000 --- a/latex-test/ref/DefaultSignatures/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{DefaultSignatures} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/Deprecated/Deprecated.tex b/latex-test/ref/Deprecated/Deprecated.tex index fa8fc20a..0ae2410b 100644 --- a/latex-test/ref/Deprecated/Deprecated.tex +++ b/latex-test/ref/Deprecated/Deprecated.tex @@ -9,9 +9,9 @@ module Deprecated ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -deprecated\ ::\ Int -\end{tabular}]\haddockbegindoc +deprecated :: Int +\end{tabular}] +{\haddockbegindoc Deprecated: Don't use this\par -Docs for something deprecated\par - +Docs for something deprecated\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/Deprecated/haddock.sty b/latex-test/ref/Deprecated/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/Deprecated/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/Deprecated/main.tex b/latex-test/ref/Deprecated/main.tex deleted file mode 100644 index 76def1cd..00000000 --- a/latex-test/ref/Deprecated/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{Deprecated} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/Example/Example.tex b/latex-test/ref/Example/Example.tex new file mode 100644 index 00000000..11f7e734 --- /dev/null +++ b/latex-test/ref/Example/Example.tex @@ -0,0 +1,30 @@ +\haddockmoduleheading{Example} +\label{module:Example} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module Example ( + split + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +split :: Int -> () +\end{tabular}] +{\haddockbegindoc +Example use.\par +\begin{quote} +{\haddockverb\begin{verbatim} +>>> split 1 +() + +\end{verbatim}} +\end{quote} +\begin{quote} +{\haddockverb\begin{verbatim} +>>> split 2 +() + +\end{verbatim}} +\end{quote}} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex index 7aaf5512..9953ce55 100644 --- a/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex +++ b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex @@ -9,17 +9,18 @@ module GadtConstructorArgs ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Boo\ where -\end{tabular}]\haddockbegindoc +data Boo where +\end{tabular}] +{\haddockbegindoc \enspace \emph{Constructors}\par \haddockbeginconstrs & \haddockdecltt{Fot} & \\ - & \qquad \haddockdecltt{:: \{} \enspace \haddockdecltt{x :: Int} & an \haddockid{x} \\ + & \qquad \haddockdecltt{:: {\char '173}} \enspace \haddockdecltt{x :: Int} & an \haddockid{x} \\ & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{y :: Int} & a \haddockid{y} \\ - & \qquad \haddockdecltt{\ \ \ \ \} ->} \enspace \haddockdecltt{Boo} & \\ + & \qquad \haddockdecltt{\ \ \ \ {\char '175} ->} \enspace \haddockdecltt{Boo} & \\ & \haddockdecltt{Fob} & Record GADT with docs \\ - & \qquad \haddockdecltt{:: \{} \enspace \haddockdecltt{w :: Int} & a \haddockid{w} \\ + & \qquad \haddockdecltt{:: {\char '173}} \enspace \haddockdecltt{w :: Int} & a \haddockid{w} \\ & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{z :: Int} & a \haddockid{z} \\ - & \qquad \haddockdecltt{\ \ \ \ \} ->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ -\end{tabulary}\par + & \qquad \haddockdecltt{\ \ \ \ {\char '175} ->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ +\end{tabulary}\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/GadtConstructorArgs/haddock.sty b/latex-test/ref/GadtConstructorArgs/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/GadtConstructorArgs/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/GadtConstructorArgs/main.tex b/latex-test/ref/GadtConstructorArgs/main.tex deleted file mode 100644 index dc1a1aa3..00000000 --- a/latex-test/ref/GadtConstructorArgs/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{GadtConstructorArgs} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex index f39bd0ec..44c052c6 100644 --- a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex +++ b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex @@ -3,39 +3,35 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module NamespacedIdentifiers ( - Foo(Bar), Bar + Foo(Bar), Bar ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Foo -\end{tabular}]\haddockbegindoc +data Foo +\end{tabular}] +{\haddockbegindoc A link to:\par -\begin{itemize} +\vbox{\begin{itemize} \item the type \haddockid{Bar}\par - \item the constructor \haddockid{Bar}\par - \item the unimported but qualified type \haddockid{A}\par - \item the unimported but qualified value \haddockid{A}\par - -\end{itemize} - +\end{itemize}} \enspace \emph{Constructors}\par \haddockbeginconstrs \haddockdecltt{=} & \haddockdecltt{Bar} & \\ -\end{tabulary}\par +\end{tabulary}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Bar -\end{tabular}]\haddockbegindoc -A link to the value \haddocktt{Foo} (which shouldn't exist).\par - +data Bar +\end{tabular}] +{\haddockbegindoc +A link to the value \haddocktt{Foo} (which shouldn't exist).\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/haddock.sty b/latex-test/ref/NamespacedIdentifier/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/NamespacedIdentifier/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/NamespacedIdentifier/main.tex b/latex-test/ref/NamespacedIdentifier/main.tex deleted file mode 100644 index 75493e12..00000000 --- a/latex-test/ref/NamespacedIdentifier/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{NamespacedIdentifiers} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex index 5ba4712c..96e9338a 100644 --- a/latex-test/ref/Simple/Simple.tex +++ b/latex-test/ref/Simple/Simple.tex @@ -9,8 +9,8 @@ module Simple ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -foo\ ::\ t -\end{tabular}]\haddockbegindoc -This is foo.\par - +foo :: t +\end{tabular}] +{\haddockbegindoc +This is foo.\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/Simple/haddock.sty b/latex-test/ref/Simple/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/Simple/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/Simple/main.tex b/latex-test/ref/Simple/main.tex deleted file mode 100644 index 36536981..00000000 --- a/latex-test/ref/Simple/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{Simple} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex index 2a8ad297..d8787704 100644 --- a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex +++ b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex @@ -3,42 +3,42 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module TypeFamilies3 ( - Foo, Bar, Baz(Baz3, Baz2, Baz1) + Foo, Bar, Baz(Baz3, Baz2, Baz1) ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -type\ family\ Foo\ a\ where -\end{tabular}]\haddockbegindoc +type family Foo a where +\end{tabular}] +{\haddockbegindoc \haddockbeginargs \haddockdecltt{Foo () = Int} \\ -\haddockdecltt{Foo \_ = ()} \\ +\haddockdecltt{Foo {\char '137} = ()} \\ \end{tabulary}\par -A closed type family\par - +A closed type family\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -type\ family\ Bar\ a -\end{tabular}]\haddockbegindoc -An open family\par - +type family Bar a +\end{tabular}] +{\haddockbegindoc +An open family\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -type\ instance\ Bar\ Int\ =\ ()\\type\ instance\ Bar\ ()\ =\ Int +type instance Bar Int = ()\\type instance Bar () = Int \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ family\ Baz\ a -\end{tabular}]\haddockbegindoc -A data family\par - +data family Baz a +\end{tabular}] +{\haddockbegindoc +A data family\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -newtype\ instance\ Baz\ Double\\data\ instance\ Baz\ Int\\data\ instance\ Baz\ () +newtype instance Baz Double\\data instance Baz Int\\data instance Baz () \end{tabular}] \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/TypeFamilies3/haddock.sty b/latex-test/ref/TypeFamilies3/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/TypeFamilies3/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/TypeFamilies3/main.tex b/latex-test/ref/TypeFamilies3/main.tex deleted file mode 100644 index 2c98043c..00000000 --- a/latex-test/ref/TypeFamilies3/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{TypeFamilies3} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex index 36d5c12b..990d2a5b 100644 --- a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex +++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex @@ -3,34 +3,34 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module UnboxedStuff ( - X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum + X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ X +data X \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Y +data Y \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Z +data Z \end{tabular}] \end{haddockdesc} \section{Unboxed type constructors} \begin{haddockdesc} -\item[ -unboxedUnit\ ::\ ({\char '43}\ {\char '43})\ ->\ ({\char '43}\ {\char '43}) -] -\item[ -unboxedTuple\ ::\ ({\char '43}\ X,\ Y\ {\char '43})\ ->\ ({\char '43}\ X,\ Y,\ Z\ {\char '43}) -] -\item[ -unboxedSum\ ::\ ({\char '43}\ X\ |\ Y\ {\char '43})\ ->\ ({\char '43}\ X\ |\ Y\ |\ Z\ {\char '43}) -] +\item[\begin{tabular}{@{}l} +unboxedUnit :: ({\char '43} {\char '43}) -> ({\char '43} {\char '43}) +\end{tabular}] +\item[\begin{tabular}{@{}l} +unboxedTuple :: ({\char '43} X, Y {\char '43}) -> ({\char '43} X, Y, Z {\char '43}) +\end{tabular}] +\item[\begin{tabular}{@{}l} +unboxedSum :: ({\char '43} X | Y {\char '43}) -> ({\char '43} X | Y | Z {\char '43}) +\end{tabular}] \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/haddock.sty b/latex-test/ref/UnboxedStuff/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/UnboxedStuff/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% 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/UnboxedStuff/main.tex b/latex-test/ref/UnboxedStuff/main.tex deleted file mode 100644 index e34c5f14..00000000 --- a/latex-test/ref/UnboxedStuff/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{UnboxedStuff} -\end{document} \ No newline at end of file diff --git a/latex-test/src/Example/Example.hs b/latex-test/src/Example/Example.hs new file mode 100644 index 00000000..42ff1646 --- /dev/null +++ b/latex-test/src/Example/Example.hs @@ -0,0 +1,11 @@ +module Example where + +-- | Example use. +-- +-- >>> split 1 +-- () +-- +-- >>> split 2 +-- () +split :: Int -> () +split _ = () -- cgit v1.2.3 From 3efdc3a8da642d5d76b2c3f10a22f0503f65456a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 11 Feb 2019 12:27:41 -0500 Subject: Remove workaround for now-fixed Clang CPP bug (#1028) Before LLVM 6.0.1 (or 10.0 on Apple LLVM), there was a bug where lines that started with an octothorpe but turned out not to lex like pragmas would have an extra line added after them. Since this bug has been fixed upstream and that it doesn't have dire consequences anyways, the workaround is not really worth it anymore - we can just tell people to update their clang version (or re-structure their pragma code). --- haddock-api/haddock-api.cabal | 2 - haddock-api/src/Haddock/Backends/Hyperlinker.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 47 +-------------------- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 49 ++++++++-------------- hypsrc-test/Main.hs | 9 +--- hypsrc-test/src/ClangCppBug.hs | 21 ---------- 6 files changed, 22 insertions(+), 110 deletions(-) delete mode 100644 hypsrc-test/src/ClangCppBug.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index a58b092a..5e8b37d8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -59,7 +59,6 @@ library , directory , filepath , ghc-boot - , ghc-boot-th , transformers hs-source-dirs: src @@ -186,7 +185,6 @@ test-suite spec , directory , filepath , ghc-boot - , ghc-boot-th , transformers build-tool-depends: diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 5ef7d9bb..251c886b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -25,7 +25,6 @@ import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache ) import UniqSupply ( mkSplitUniqSupply ) -import SysTools.Info ( getCompilerInfo' ) -- | Generate hyperlinked source for given interfaces. @@ -62,12 +61,11 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of , hie_types = types , hie_hs_src = rawSrc } <- fmap fst (readHieFile (initNameCache u []) hfp) - comp <- getCompilerInfo' df -- Get the AST and tokens corresponding to the source file we want let mast | M.size asts == 1 = snd <$> M.lookupMin asts | otherwise = M.lookup (mkFastString file) asts - tokens = parse comp df file rawSrc + tokens = parse df file rawSrc -- Produce and write out the hyperlinked sources case mast of diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 1d5576cc..0bd467e1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -6,13 +6,9 @@ import Control.Applicative ( Alternative(..) ) import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC - -import GHC.LanguageExtensions.Type import BasicTypes ( IntegralLit(..) ) import DynFlags -import qualified EnumSet as E import ErrUtils ( emptyMessages ) import FastString ( mkFastString ) import Lexer ( P(..), ParseResult(..), PState(..), Token(..) @@ -29,12 +25,11 @@ import Haddock.GhcUtils -- Result should retain original file layout (including comments, -- whitespace, and CPP). parse - :: CompilerInfo -- ^ Underlying CC compiler (whatever expanded CPP) - -> DynFlags -- ^ Flags for this module + :: DynFlags -- ^ Flags for this module -> FilePath -- ^ Path to the source of this module -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module -> [T.Token] -parse comp dflags fpath bs = case unP (go False []) initState of +parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++ ": " ++ showSDoc dflags errMsg @@ -43,7 +38,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of initState = mkPStatePure pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - needPragHack' = needPragHack comp dflags pflags = mkParserFlags' (warningFlags dflags) (extensionFlags dflags) (thisPackage dflags) @@ -125,12 +119,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of pure (bEnd'', False) - -- See 'needPragHack' - ITclose_prag{} - | needPragHack' - , '\n' `BSC.elem` spaceBStr - -> getInput >>= \(b,p) -> setInput (b,advanceSrcLoc p '\n') >> pure (bEnd, False) - _ -> pure (bEnd, inPragDef) let tokBStr = splitStringBuffer bStart bEnd' @@ -155,37 +143,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of pure ([unkTok], False) --- | This is really, really, /really/ gross. Problem: consider a Haskell --- file that looks like: --- --- @ --- {-# LANGUAGE CPP #-} --- module SomeMod where --- --- #define SIX 6 --- --- {-# INLINE foo --- #-} --- foo = 1 --- @ --- --- Clang's CPP replaces the @#define SIX 6@ line with an empty line (as it --- should), but get confused about @#-}@. I'm guessing it /starts/ by --- parsing that as a pre-processor directive and, when it fails to, it just --- leaves the line alone. HOWEVER, it still adds an extra newline. =.= --- --- This function makes sure that the Hyperlinker backend also adds that --- extra newline (or else our spans won't line up with GHC's anymore). -needPragHack :: CompilerInfo -> DynFlags -> Bool -needPragHack comp dflags = isCcClang && E.member Cpp (extensionFlags dflags) - where - isCcClang = case comp of - GCC -> False - Clang -> True - AppleClang -> True - AppleClang51 -> True - UnknownCC -> False - -- | Get the input getInput :: P (StringBuffer, RealSrcLoc) getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index ff18cb40..1273a45a 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -5,8 +5,7 @@ import Test.Hspec import Test.QuickCheck import GHC ( runGhc, getSessionDynFlags ) -import DynFlags ( CompilerInfo, DynFlags ) -import SysTools.Info ( getCompilerInfo' ) +import DynFlags ( DynFlags ) import Control.Monad.IO.Class import Data.String ( fromString ) @@ -17,13 +16,12 @@ import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types -withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO () +withDynFlags :: (DynFlags -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs []) runGhc (Just libDir) $ do dflags <- getSessionDynFlags - cinfo <- liftIO $ getCompilerInfo' dflags - liftIO $ cont (dflags, cinfo) + liftIO $ cont dflags main :: IO () @@ -60,60 +58,54 @@ instance Arbitrary NoGhcRewrite where parseSpec :: Spec parseSpec = around withDynFlags $ do - it "is total" $ \(dflags, cinfo) -> - property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0) + it "is total" $ \dflags -> + property $ \src -> length (parse dflags "" (fromString src)) `shouldSatisfy` (>= 0) - it "retains file layout" $ \(dflags, cinfo) -> + it "retains file layout" $ \dflags -> property $ \(NoGhcRewrite src) -> let orig = fromString src - lexed = BS.concat (map tkValue (parse cinfo dflags "" orig)) + lexed = BS.concat (map tkValue (parse dflags "" orig)) in lexed == orig context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ \(dflags, cinfo) -> + it "should ignore content until the end of line" $ \dflags -> shouldParseTo "-- some very simple comment\nidentifier" [TkComment, TkSpace, TkIdentifier] - cinfo dflags - it "should allow endline escaping" $ \(dflags, cinfo) -> + it "should allow endline escaping" $ \dflags -> shouldParseTo "#define first line\\\nsecond line\\\nand another one" [TkCpp] - cinfo dflags context "when parsing multi-line comments" $ do - it "should support nested comments" $ \(dflags, cinfo) -> + it "should support nested comments" $ \dflags -> shouldParseTo "{- comment {- nested -} still comment -} {- next comment -}" [TkComment, TkSpace, TkComment] - cinfo dflags - it "should distinguish compiler pragma" $ \(dflags, cinfo) -> + it "should distinguish compiler pragma" $ \dflags -> shouldParseTo "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" [TkComment, TkPragma, TkComment] - cinfo dflags - it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do + it "should recognize preprocessor directives" $ \dflags -> do shouldParseTo "\n#define foo bar" [TkCpp] - cinfo dflags shouldParseTo "x # y" [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] - cinfo dflags - it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do + it "should distinguish basic language constructs" $ \dflags -> do shouldParseTo "(* 2) <$> (\"abc\", foo)" @@ -121,7 +113,6 @@ parseSpec = around withDynFlags $ do , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] - cinfo dflags shouldParseTo @@ -131,7 +122,6 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] - cinfo dflags shouldParseTo @@ -142,10 +132,9 @@ parseSpec = around withDynFlags $ do , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] - cinfo dflags - it "should parse do-notation syntax" $ \(dflags, cinfo) -> do + it "should parse do-notation syntax" $ \dflags -> do shouldParseTo "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace @@ -153,7 +142,6 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] - cinfo dflags shouldParseTo @@ -166,10 +154,9 @@ parseSpec = around withDynFlags $ do , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] - cinfo dflags where - shouldParseTo :: ByteString -> [TokenType] -> CompilerInfo -> DynFlags -> Expectation - shouldParseTo str tokens cinfo dflags = [ tkType tok - | tok <- parse cinfo dflags "" str - , not (BS.null (tkValue tok)) ] `shouldBe` tokens + shouldParseTo :: ByteString -> [TokenType] -> DynFlags -> Expectation + shouldParseTo str tokens dflags = [ tkType tok + | tok <- parse dflags "" str + , not (BS.null (tkValue tok)) ] `shouldBe` tokens diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 1963753d..f7614927 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -20,18 +20,11 @@ checkConfig = CheckConfig , ccfgEqual = (==) `on` dumpXml } where - -- The whole point of the ClangCppBug is to demonstrate a situation where - -- line numbers may vary (and test that links still work). Consequently, we - -- strip out line numbers for this test case. - strip f | takeBaseName f == "ClangCppBug" - = stripAnchors' . stripLinks' . stripIds' . stripIds'' . stripFooter - | otherwise - = stripAnchors' . stripLinks' . stripIds' . stripFooter + strip _ = stripAnchors' . stripLinks' . stripIds' . stripFooter stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name stripIds' = stripIdsWhen $ \name -> "local-" `isPrefixOf` name - stripIds'' = stripIdsWhen $ \name -> "line-" `isPrefixOf` name dirConfig :: DirConfig diff --git a/hypsrc-test/src/ClangCppBug.hs b/hypsrc-test/src/ClangCppBug.hs deleted file mode 100644 index 4b0bc35f..00000000 --- a/hypsrc-test/src/ClangCppBug.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE CPP #-} -module ClangCppBug where - -foo :: Int -foo = 1 - --- Clang doesn't mind these: -#define BAX 2 -{-# INLINE bar #-} - -bar :: Int -bar = 3 - --- But it doesn't like this: -{-# RULES -"bar/qux" bar = qux -"qux/foo" qux = foo - #-} - -qux :: Int -qux = 88 -- cgit v1.2.3 From dc78937c638d9e1e4f4cfd18f90ecf79d8649c06 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 26 Jan 2019 21:45:59 +0200 Subject: Matching changes in GHC for #16236 (cherry picked from commit 3ee6526d4ae7bf4deb7cd1caf24b3d7355573576) --- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- 4 files changed, 10 insertions(+), 10 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index cc096a7a..c62a9311 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1029,9 +1029,9 @@ ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty -ppLHsTypeArg unicode (HsTypeArg ki) = atSign unicode <> - ppLParendType unicode ki -ppLHsTypeArg _ (HsArgPar _) = text "" +ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode ki +ppLHsTypeArg _ (HsArgPar _) = text "" ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 56a79d57..40d630b0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1135,8 +1135,8 @@ ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty -ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg ki) = atSign unicode <> - ppLParendType unicode qual emptyCtxts ki +ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode qual emptyCtxts ki ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d89efb5a..463411b4 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1140,7 +1140,7 @@ extractPatternSyn nm t tvs cons = | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty - mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki mkAppTyArg f (HsArgPar _) = HsParTy noExt f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] @@ -1162,8 +1162,8 @@ extractRecSel nm t tvs (L _ con : rest) = | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty - mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExt f + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 88238f04..ceea2444 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -186,8 +186,8 @@ renameLType = mapM renameType renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI) renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty ; return $ HsValArg ty' } -renameLTypeArg (HsTypeArg ki) = do { ki' <- renameLKind ki - ; return $ HsTypeArg ki' } +renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki + ; return $ HsTypeArg l ki' } renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) -- cgit v1.2.3 From 91c65619149f4866abcce33a56036e2e2454629f Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 25 May 2019 16:47:55 +0530 Subject: update for new way to store hiefile headers --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 251c886b..7571db9e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -19,7 +19,7 @@ import System.Directory import System.FilePath import HieTypes ( HieFile(..), HieASTs(..) ) -import HieBin ( readHieFile ) +import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) @@ -60,7 +60,8 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc - } <- fmap fst (readHieFile (initNameCache u []) hfp) + } <- (hie_file_result . fst) + <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want let mast | M.size asts == 1 = snd <$> M.lookupMin asts -- cgit v1.2.3 From 63c7e87de4fa94cea9eb1b253054a316d3d75e1c Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 28 Sep 2019 12:09:24 +0530 Subject: Fix crash when there are no srcspans in the file due to CPP --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 19 +++++++++++-------- 2 files changed, 12 insertions(+), 9 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 412d8391..1b49fba3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -432,7 +432,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} - ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces + ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 7571db9e..3acd91be 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -7,7 +7,7 @@ module Haddock.Backends.Hyperlinker import Haddock.Types -import Haddock.Utils (writeUtf8File) +import Haddock.Utils (writeUtf8File, out, verbose, Verbosity) import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types @@ -32,27 +32,28 @@ import UniqSupply ( mkSplitUniqSupply ) -- Note that list of interfaces should also contain interfaces normally hidden -- when generating documentation. Otherwise this could lead to dead links in -- produced source. -ppHyperlinkedSource :: FilePath -- ^ Output directory +ppHyperlinkedSource :: Verbosity + -> FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do +ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces + mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir srcs = (srcs', M.mapKeys moduleName srcs') -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of +ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO () +ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of Just hfp -> do -- Parse the GHC-produced HIE file u <- mkSplitUniqSupply 'a' @@ -75,8 +76,10 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of in writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing | M.size asts == 0 -> return () - | otherwise -> error $ unwords [ "couldn't find ast for" - , file, show (M.keys asts) ] + | otherwise -> do + out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + return () Nothing -> return () where df = ifaceDynFlags iface -- cgit v1.2.3 From 5459ca8a76825da59ff4c1c11d74812d1931da50 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Oct 2019 15:11:22 -0400 Subject: Prefer un-hyperlinked sources to no sources It is possible to fail to extract an HIE ast. This is however not a reason to produce _no_ output - we should still make a colorized HTML page. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 38 ++++++++++++++-------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 2 +- 2 files changed, 26 insertions(+), 14 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 3acd91be..2e665204 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -18,12 +18,13 @@ import Data.Maybe import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieASTs(..) ) +import HieTypes ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) ) import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache ) +import SrcLoc ( mkRealSrcLoc, realSrcLocSpan ) import UniqSupply ( mkSplitUniqSupply ) @@ -65,27 +66,38 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want - let mast | M.size asts == 1 = snd <$> M.lookupMin asts - | otherwise = M.lookup (mkFastString file) asts + let fileFs = mkFastString file + mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup fileFs asts + ast = fromMaybe (emptyHieAst fileFs) mast + fullAst = recoverFullIfaceTypes df types ast tokens = parse df file rawSrc + -- Warn if we didn't find an AST, but there were still ASTs + if M.null asts + then pure () + else out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + -- Produce and write out the hyperlinked sources - case mast of - Just ast -> - let fullAst = recoverFullIfaceTypes df types ast - in writeUtf8File path . renderToString pretty . render' fullAst $ tokens - Nothing - | M.size asts == 0 -> return () - | otherwise -> do - out verbosity verbose $ unwords [ "couldn't find ast for" - , file, show (M.keys asts) ] - return () + writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing -> return () where df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir hypSrcModuleFile (ifaceMod iface) + emptyNodeInfo = NodeInfo + { nodeAnnotations = mempty + , nodeType = [] + , nodeIdentifiers = mempty + } + emptyHieAst fileFs = Node + { nodeInfo = emptyNodeInfo + , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + , nodeChildren = [] + } + -- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 4e8b88d2..2c48e00b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -102,7 +102,7 @@ type PrintedType = String -- > hieAst -- -- However, this is very inefficient (both in time and space) because the --- mutliple calls to 'recoverFullType' don't share intermediate results. This +-- multiple calls to 'recoverFullType' don't share intermediate results. This -- function fixes that. recoverFullIfaceTypes :: DynFlags -- cgit v1.2.3 From 9a737d67d97ec4310b1ae89de640093c9d89e372 Mon Sep 17 00:00:00 2001 From: Kleidukos Date: Thu, 19 Mar 2020 16:02:31 +0100 Subject: Replace the 'caption' class so that the collapsible sections are shown --- haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 1901cf05..edab4b16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -182,7 +182,7 @@ hackMarkup fmt' currPkg h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ "caption" + col' = collapseControl id_ "subheading" summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] -- cgit v1.2.3