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') 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') 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 39251d3aa339958aafd8b955f41323a8b0b60012 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 20 Dec 2018 16:16:30 -0500 Subject: Load plugins when compiling each module (#983) * WIP: Load (typechecker) plugins from language pragmas * Revert "Load plugins when starting a GHC session (#905)" This reverts commit 72d82e52f2a6225686d9668790ac33c1d1743193. * Simplify plugin initialization code --- haddock-api/src/Haddock.hs | 6 +----- haddock-api/src/Haddock/Interface.hs | 9 ++++++++- 2 files changed, 9 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 7a2df3a2..43f600b4 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -76,7 +76,6 @@ import Packages import Panic (handleGhcException) import Module import FastString -import qualified DynamicLoading -------------------------------------------------------------------------------- -- * Exception handling @@ -450,10 +449,7 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' - hscenv <- GHC.getSession - dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'') - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' + ghcActs dynflags'' where -- ignore sublists of flags that start with "+RTS" and end in "-RTS" diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 759d5d03..3d54970b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -64,6 +64,7 @@ import Name (nameIsFromExternalPackage, nameOccName) import OccName (isTcOcc) import RdrName (unQualOK, gre_name, globalRdrEnvElts) import ErrUtils (withTiming) +import DynamicLoading (initializePlugins) #if defined(mingw32_HOST_OS) import System.IO @@ -177,7 +178,13 @@ createIfaces verbosity flags instIfaceMap mods = do processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum + + -- Since GHC 8.6, plugins are initialized on a per module basis + hsc_env' <- getSession + dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum)) + let modsum' = modsum { ms_hspp_opts = dynflags' } + + tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." -- 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') 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') 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: Fri, 25 Jan 2019 10:26:16 -0500 Subject: Fix #1004 with a pinch of dropForAlls --- haddock-api/src/Haddock/Convert.hs | 2 +- html-test/ref/Bug1004.html | 2072 ++++++++++++++++++++++++++++++++++++ html-test/src/Bug1004.hs | 3 + 3 files changed, 2076 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/Bug1004.html create mode 100644 html-test/src/Bug1004.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6eee353b..7735ed0d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -274,7 +274,7 @@ synifyTyCon coax tc -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of + = case splitFunTys (dropForAlls (tyConKind tc)) of (_, ret_kind) | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * | otherwise -> Just (synifyKindSig ret_kind) diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html new file mode 100644 index 00000000..9179e252 --- /dev/null +++ b/html-test/ref/Bug1004.html @@ -0,0 +1,2072 @@ +Bug1004
      Safe HaskellSafe

      Bug1004

      Synopsis

      Documentation

      data Product (f :: k -> Type) (g :: k -> Type) (a :: k) #

      Lifted product of functors.

      Constructors

      Pair (f a) (g a)

      Instances

      Instances details
      Generic1 (Product f g :: k -> Type)
      Instance details

      Defined in Data.Functor.Product

      Associated Types

      type Rep1 (Product f g) :: k -> Type #

      Methods

      from1 :: Product f g a -> Rep1 (Product f g) a #

      to1 :: Rep1 (Product f g) a -> Product f g a #

      (Monad f, Monad g) => Monad (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      (>>=) :: Product f g a -> (a -> Product f g b) -> Product f g b #

      (>>) :: Product f g a -> Product f g b -> Product f g b #

      return :: a -> Product f g a #

      fail :: String -> Product f g a #

      (Functor f, Functor g) => Functor (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      fmap :: (a -> b) -> Product f g a -> Product f g b #

      (<$) :: a -> Product f g b -> Product f g a #

      (MonadFix f, MonadFix g) => MonadFix (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mfix :: (a -> Product f g a) -> Product f g a #

      (Applicative f, Applicative g) => Applicative (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      pure :: a -> Product f g a #

      (<*>) :: Product f g (a -> b) -> Product f g a -> Product f g b #

      liftA2 :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

      (*>) :: Product f g a -> Product f g b -> Product f g b #

      (<*) :: Product f g a -> Product f g b -> Product f g a #

      (Foldable f, Foldable g) => Foldable (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      fold :: Monoid m => Product f g m -> m #

      foldMap :: Monoid m => (a -> m) -> Product f g a -> m #

      foldr :: (a -> b -> b) -> b -> Product f g a -> b #

      foldr' :: (a -> b -> b) -> b -> Product f g a -> b #

      foldl :: (b -> a -> b) -> b -> Product f g a -> b #

      foldl' :: (b -> a -> b) -> b -> Product f g a -> b #

      foldr1 :: (a -> a -> a) -> Product f g a -> a #

      foldl1 :: (a -> a -> a) -> Product f g a -> a #

      toList :: Product f g a -> [a] #

      null :: Product f g a -> Bool #

      length :: Product f g a -> Int #

      elem :: Eq a => a -> Product f g a -> Bool #

      maximum :: Ord a => Product f g a -> a #

      minimum :: Ord a => Product f g a -> a #

      sum :: Num a => Product f g a -> a #

      product :: Num a => Product f g a -> a #

      (Traversable f, Traversable g) => Traversable (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      traverse :: Applicative f0 => (a -> f0 b) -> Product f g a -> f0 (Product f g b) #

      sequenceA :: Applicative f0 => Product f g (f0 a) -> f0 (Product f g a) #

      mapM :: Monad m => (a -> m b) -> Product f g a -> m (Product f g b) #

      sequence :: Monad m => Product f g (m a) -> m (Product f g a) #

      (Eq1 f, Eq1 g) => Eq1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftEq :: (a -> b -> Bool) -> Product f g a -> Product f g b -> Bool #

      (Ord1 f, Ord1 g) => Ord1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftCompare :: (a -> b -> Ordering) -> Product f g a -> Product f g b -> Ordering #

      (Read1 f, Read1 g) => Read1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Product f g a) #

      liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [Product f g a] #

      liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Product f g a) #

      liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Product f g a] #

      (Show1 f, Show1 g) => Show1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Product f g a -> ShowS #

      liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [Product f g a] -> ShowS #

      (MonadZip f, MonadZip g) => MonadZip (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mzip :: Product f g a -> Product f g b -> Product f g (a, b) #

      mzipWith :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

      munzip :: Product f g (a, b) -> (Product f g a, Product f g b) #

      (Alternative f, Alternative g) => Alternative (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      empty :: Product f g a #

      (<|>) :: Product f g a -> Product f g a -> Product f g a #

      some :: Product f g a -> Product f g [a] #

      many :: Product f g a -> Product f g [a] #

      (MonadPlus f, MonadPlus g) => MonadPlus (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mzero :: Product f g a #

      mplus :: Product f g a -> Product f g a -> Product f g a #

      (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      (==) :: Product f g a -> Product f g a -> Bool #

      (/=) :: Product f g a -> Product f g a -> Bool #

      (Typeable a, Typeable f, Typeable g, Typeable k, Data (f a), Data (g a)) => Data (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g0. g0 -> c g0) -> Product f g a -> c (Product f g a) #

      gunfold :: (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (Product f g a) #

      toConstr :: Product f g a -> Constr #

      dataTypeOf :: Product f g a -> DataType #

      dataCast1 :: Typeable t => (forall d. Data d => c (t d)) -> Maybe (c (Product f g a)) #

      dataCast2 :: Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Product f g a)) #

      gmapT :: (forall b. Data b => b -> b) -> Product f g a -> Product f g a #

      gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

      gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

      gmapQ :: (forall d. Data d => d -> u) -> Product f g a -> [u] #

      gmapQi :: Int -> (forall d. Data d => d -> u) -> Product f g a -> u #

      gmapM :: Monad m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      compare :: Product f g a -> Product f g a -> Ordering #

      (<) :: Product f g a -> Product f g a -> Bool #

      (<=) :: Product f g a -> Product f g a -> Bool #

      (>) :: Product f g a -> Product f g a -> Bool #

      (>=) :: Product f g a -> Product f g a -> Bool #

      max :: Product f g a -> Product f g a -> Product f g a #

      min :: Product f g a -> Product f g a -> Product f g a #

      (Read1 f, Read1 g, Read a) => Read (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      readsPrec :: Int -> ReadS (Product f g a) #

      readList :: ReadS [Product f g a] #

      readPrec :: ReadPrec (Product f g a) #

      readListPrec :: ReadPrec [Product f g a] #

      (Show1 f, Show1 g, Show a) => Show (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      showsPrec :: Int -> Product f g a -> ShowS #

      show :: Product f g a -> String #

      showList :: [Product f g a] -> ShowS #

      Generic (Product f g a)
      Instance details

      Defined in Data.Functor.Product

      Associated Types

      type Rep (Product f g a) :: Type -> Type #

      Methods

      from :: Product f g a -> Rep (Product f g a) x #

      to :: Rep (Product f g a) x -> Product f g a #

      type Rep1 (Product f g :: k -> Type)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      type Rep1 (Product f g :: k -> Type) = D1 (MetaData "Product" "Data.Functor.Product" "base" False) (C1 (MetaCons "Pair" PrefixI False) (S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 f) :*: S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 g)))
      type Rep (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      type Rep (Product f g a) = D1 (MetaData "Product" "Data.Functor.Product" "base" False) (C1 (MetaCons "Pair" PrefixI False) (S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (f a)) :*: S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (g a))))
      \ No newline at end of file diff --git a/html-test/src/Bug1004.hs b/html-test/src/Bug1004.hs new file mode 100644 index 00000000..d789e77f --- /dev/null +++ b/html-test/src/Bug1004.hs @@ -0,0 +1,3 @@ +module Bug1004 (Product(..)) where + +import Data.Functor.Product -- cgit v1.2.3 From dd47029cb29c80b1ab4db520c9c2ce4dca37f833 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 19 Jul 2018 11:42:26 -0700 Subject: Support value/type namespaces on identifier links Identifier links can be prefixed with a 'v' or 't' to indicate the value or type namespace of the desired identifier. For example: -- | Some link to a value: v'Data.Functor.Identity' -- -- Some link to a type: t'Data.Functor.Identity' The default is still the type (with a warning about the ambiguity) --- doc/markup.rst | 10 ++ haddock-api/src/Haddock.hs | 3 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 55 ++++++-- .../src/Haddock/Interface/ParseModuleHeader.hs | 3 +- haddock-api/src/Haddock/Parser.hs | 13 +- haddock-api/src/Haddock/Types.hs | 6 + .../src/Documentation/Haddock/Parser.hs | 22 ++-- haddock-library/src/Documentation/Haddock/Types.hs | 10 ++ .../test/Documentation/Haddock/ParserSpec.hs | 6 + html-test/Main.hs | 2 +- html-test/ref/Bug253.html | 16 +-- html-test/ref/NamespacedIdentifiers.html | 146 +++++++++++++++++++++ html-test/src/NamespacedIdentifiers.hs | 13 ++ .../NamespacedIdentifier/NamespacedIdentifiers.tex | 41 ++++++ latex-test/ref/NamespacedIdentifier/haddock.sty | 57 ++++++++ latex-test/ref/NamespacedIdentifier/main.tex | 11 ++ .../NamespacedIdentifier/NamespacedIdentifier.hs | 13 ++ 17 files changed, 388 insertions(+), 39 deletions(-) create mode 100644 html-test/ref/NamespacedIdentifiers.html create mode 100644 html-test/src/NamespacedIdentifiers.hs create mode 100644 latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex create mode 100644 latex-test/ref/NamespacedIdentifier/haddock.sty create mode 100644 latex-test/ref/NamespacedIdentifier/main.tex create mode 100644 latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs (limited to 'haddock-api/src/Haddock') diff --git a/doc/markup.rst b/doc/markup.rst index 9fb0209a..48a6f4ad 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -913,6 +913,16 @@ If ``M.T`` is not otherwise in scope, then Haddock will simply emit a link pointing to the entity ``T`` exported from module ``M`` (without checking to see whether either ``M`` or ``M.T`` exist). +Since values and types live in different namespaces in Haskell, it is +possible for a reference such as ``'X'`` to be ambiguous. In such a case, +Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t`` +(for type) immediately before the link: :: + + -- | An implicit reference to 'X', the type constructor + -- An explicit reference to v'X', the data constructor + -- An explicit reference to t'X', the type constructor + data X = X + To make life easier for documentation writers, a quoted identifier is only interpreted as such if the quotes surround a lexically valid Haskell identifier. This means, for example, that it normally isn't diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 358e5c3a..1378c173 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -42,6 +42,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf) @@ -662,7 +663,7 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags Nothing str + return . Just $! second rdrName $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 59ad4fdf..66083cf5 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -34,8 +34,8 @@ import Haddock.Types import Name import Outputable ( showPpr, showSDoc ) import RdrName +import RdrHsSyn (setRdrNameSpace) import EnumSet -import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -89,24 +89,37 @@ processModuleHeader dflags pkgName gre safety mayStr = do -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) +rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier x -> do + DocIdentifier (NsRdrName ns x) -> do + let occ = rdrNameOcc x + isValueName = isDataOcc occ || isVarOcc occ + + let valueNsChoices | isValueName = [x] + | otherwise = [] -- is this ever possible? + typeNsChoices | isValueName = [setRdrNameSpace x tcName] + | otherwise = [x] + -- Generate the choices for the possible kind of thing this - -- is. - let choices = dataTcOccs x + -- is. We narrow down the possibilities with the namespace (if + -- there is one). + let choices = case ns of + Value -> valueNsChoices + Type -> typeNsChoices + None -> valueNsChoices ++ typeNsChoices -- Lookup any GlobalRdrElts that match the choices. case concatMap (\c -> lookupGRE_RdrName c gre) choices of -- We found no names in the env so we start guessing. [] -> case choices of - -- This shouldn't happen as 'dataTcOccs' always returns at least its input. - [] -> pure (DocMonospaced (DocString (showPpr dflags x))) + -- The only way this can happen is if a value namespace was + -- specified on something that cannot be a value. + [] -> invalidValue dflags x -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -116,7 +129,7 @@ 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 a + a:_ -> outOfScope dflags ns a -- There is only one name in the environment that matches so -- use it. @@ -155,17 +168,23 @@ 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 -> RdrName -> ErrMsgM (Doc a) -outOfScope dflags x = +outOfScope :: DynFlags -> Namespace -> 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 where + prefix = case ns of + Value -> "the value " + Type -> "the type " + None -> "" + warnAndMonospace a = do - tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it anyway."] + 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)) @@ -184,7 +203,7 @@ ambiguous dflags x gres = do msg = "Warning: " ++ x_str ++ " 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 hiding some imports.\n" ++ + " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to " ++ x_str ++ " 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 @@ -198,3 +217,13 @@ ambiguous dflags x gres = do 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 dflags x = do + tell ["Warning: '" ++ showPpr 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))) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 050901b6..802ea773 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -16,7 +16,6 @@ import Data.Char import DynFlags import Haddock.Parser import Haddock.Types -import RdrName -- ----------------------------------------------------------------------------- -- Parsing module headers @@ -24,7 +23,7 @@ import RdrName -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) parseModuleHeader dflags pkgName str0 = let getKey :: String -> String -> (Maybe String,String) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index e31ea6a8..8b7dda7c 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -15,26 +15,27 @@ module Haddock.Parser ( parseParas import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types +import Haddock.Types (NsRdrName(..)) import DynFlags ( DynFlags ) import FastString ( fsLit ) import Lexer ( mkPState, unP, ParseResult(POk) ) import Parser ( parseIdentifier ) import RdrName ( RdrName ) -import SrcLoc ( mkRealSrcLoc, unLoc ) +import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod RdrName +parseString :: DynFlags -> String -> DocH mod NsRdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> String -> Maybe RdrName -parseIdent dflags str0 = +parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName +parseIdent dflags ns str0 = let buffer = stringToStringBuffer str0 realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) + POk _ (L _ name) -> Just (NsRdrName ns name) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index a4ef5f82..e8da4120 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -284,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty) -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | An 'RdrName' tagged with some type/value namespace information. +data NsRdrName = NsRdrName + { namespace :: !Namespace + , rdrName :: !RdrName + } + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 82d65a0a..e9b1c496 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -28,6 +28,7 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) +import Data.Foldable (asum) import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -75,24 +76,24 @@ isSymbolChar c = not (isPuncChar c) && case generalCategory c of #endif -- | Identifier string surrounded with opening and closing quotes/backticks. -type Identifier = (Char, String, Char) +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 -toRegular = fmap (\(_, x, _) -> x) +toRegular = fmap (\(Identifier _ _ x _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string. -overIdentifier :: (String -> Maybe a) +overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where - g (DocIdentifier (o, x, e)) = case f x of - Nothing -> DocString $ o : x ++ [e] + g (DocIdentifier (Identifier ns o x e)) = case f ns x of + Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e] Just x' -> DocIdentifier x' g DocEmpty = DocEmpty g (DocAppend x x') = DocAppend (g x) (g x') @@ -314,7 +315,8 @@ markdownImage :: Parser (DocH mod Identifier) markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) - stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r]) + stringMarkup = plainMarkup (const "") renderIdent + renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) @@ -857,9 +859,13 @@ parseValid = p some -- 'String' from the string it deems valid. 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 (o, vid, e) + return $ DocIdentifier (Identifier ns o vid e) where - idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') + idDelim = Parsec.oneOf "'`" diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index f8f7d353..ba2f873c 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -203,6 +203,16 @@ instance Bitraversable DocH where bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif +-- | The namespace qualification for an identifier. +data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show) + +-- | Render the a namespace into the same format it was initially parsed. +renderNs :: Namespace -> String +renderNs Value = "v" +renderNs Type = "t" +renderNs None = "" + + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 6269184a..e186a5cf 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -132,6 +132,12 @@ spec = do it "can parse an identifier that starts with an underscore" $ do "'_x'" `shouldParseTo` DocIdentifier "_x" + it "can parse value-namespaced identifiers" $ do + "v'foo'" `shouldParseTo` DocIdentifier "foo" + + it "can parse type-namespaced identifiers" $ do + "t'foo'" `shouldParseTo` DocIdentifier "foo" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" diff --git a/html-test/Main.hs b/html-test/Main.hs index d65a5087..26eefe4a 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -45,7 +45,7 @@ stripIfRequired mdl = -- | List of modules in which we don't 'stripLinks' preserveLinksModules :: [String] -preserveLinksModules = ["Bug253"] +preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"] ingoredTests :: [FilePath] ingoredTests = diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html index a1c0f905..a01c9578 100644 --- a/html-test/ref/Bug253.html +++ b/html-test/ref/Bug253.html @@ -4,9 +4,9 @@ />Bug253
      Safe HaskellSafe

      NamespacedIdentifiers

      Synopsis

      Documentation

      data Foo #

      A link to:

      • the type Bar
      • the constructor Bar
      • the unimported but qualified type A
      • the unimported but qualified value A

      Constructors

      Bar 

      data Bar #

      A link to the value Foo (which shouldn't exist).

      diff --git a/html-test/src/NamespacedIdentifiers.hs b/html-test/src/NamespacedIdentifiers.hs new file mode 100644 index 00000000..6f59d247 --- /dev/null +++ b/html-test/src/NamespacedIdentifiers.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar diff --git a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex new file mode 100644 index 00000000..f39bd0ec --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{NamespacedIdentifiers} +\label{module:NamespacedIdentifiers} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module NamespacedIdentifiers ( + Foo(Bar), Bar + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Foo +\end{tabular}]\haddockbegindoc +A link to:\par +\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} + +\enspace \emph{Constructors}\par +\haddockbeginconstrs +\haddockdecltt{=} & \haddockdecltt{Bar} & \\ +\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 + +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/haddock.sty b/latex-test/ref/NamespacedIdentifier/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/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/NamespacedIdentifier/main.tex b/latex-test/ref/NamespacedIdentifier/main.tex new file mode 100644 index 00000000..75493e12 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/main.tex @@ -0,0 +1,11 @@ +\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/src/NamespacedIdentifier/NamespacedIdentifier.hs b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs new file mode 100644 index 00000000..6f59d247 --- /dev/null +++ b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar -- cgit v1.2.3 From a5199600c39d25d7b71dcb2328000c1c49ad95a2 Mon Sep 17 00:00:00 2001 From: Alec Theriault 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') 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: Mon, 25 Feb 2019 21:53:56 -0800 Subject: Fix standalone deriving docs Docs on standalone deriving decls for classes with associated types should be associated with the class instance, not the associated type instance. Fixes #1033 --- haddock-api/src/Haddock/Interface/Create.hs | 4 +- html-test/ref/Bug1033.html | 222 ++++++++++++++++++++++++++++ html-test/src/Bug1033.hs | 11 ++ 3 files changed, 235 insertions(+), 2 deletions(-) create mode 100644 html-test/ref/Bug1033.html create mode 100644 html-test/src/Bug1033.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a4408434..146c3cc8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -132,8 +132,8 @@ createInterface tm flags modMap instIfaceMap = do fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances + $ map getName fam_instances + ++ map getName instances -- Locations of all TH splices splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html new file mode 100644 index 00000000..32a9f6d3 --- /dev/null +++ b/html-test/ref/Bug1033.html @@ -0,0 +1,222 @@ +Bug1033
      Safe HaskellSafe

      Bug1033

      Documentation

      data Foo #

      Constructors

      Foo

      Instances

      Instances details
      Generic Foo #

      This does some generic foos.

      Instance details

      Defined in Bug1033

      Associated Types

      type Rep Foo :: Type -> Type #

      Methods

      from :: Foo -> Rep Foo x #

      to :: Rep Foo x -> Foo #

      type Rep Foo #
      Instance details

      Defined in Bug1033

      type Rep Foo = D1 (MetaData "Foo" "Bug1033" "main" False) (C1 (MetaCons "Foo" PrefixI False) (U1 :: Type -> Type))
      \ No newline at end of file diff --git a/html-test/src/Bug1033.hs b/html-test/src/Bug1033.hs new file mode 100644 index 00000000..fdf5a57e --- /dev/null +++ b/html-test/src/Bug1033.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Bug1033 where + +import GHC.Generics + +data Foo = Foo + +-- | This does some generic foos. +deriving instance Generic Foo -- cgit v1.2.3 From b682041ed1cbeaf5aa501f85e4e46a6d2e39da3a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 26 Feb 2019 08:46:45 -0800 Subject: Fix bogus identifier defaulting This avoids a situation in which an identifier would get defaulted to a completely different identifier. Prior to this commit, the 'Bug1035' test case would hyperlink 'Foo' into 'Bar'! Fixes #1035. --- haddock-api/src/Haddock/Interface/LexParseRn.hs | 14 +-- html-test/ref/Bug1035.html | 146 ++++++++++++++++++++++++ html-test/src/Bug1035.hs | 9 ++ 3 files changed, 160 insertions(+), 9 deletions(-) create mode 100644 html-test/ref/Bug1035.html create mode 100644 html-test/src/Bug1035.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index faf23728..0b40ed3c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -19,7 +19,6 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Avail import Control.Arrow import Control.Monad import Data.Functor (($>)) @@ -200,10 +199,9 @@ ambiguous :: DynFlags -> [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 + let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to the one defined " ++ defnLoc dflt @@ -212,12 +210,10 @@ ambiguous dflags x gres = do -- 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 (x $> dflt)) + when (length (gresToAvailInfo gres) > 1) $ tell [msg] + pure (DocIdentifier (x $> gre_name dflt)) where - isLocalName (nameSrcLoc -> RealSrcLoc {}) = True - isLocalName _ = False - defnLoc = showSDoc dflags . pprNameDefnLoc + defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name -- | Handle value-namespaced names that cannot be for values. -- diff --git a/html-test/ref/Bug1035.html b/html-test/ref/Bug1035.html new file mode 100644 index 00000000..946fc235 --- /dev/null +++ b/html-test/ref/Bug1035.html @@ -0,0 +1,146 @@ +Bug1035
      Safe HaskellSafe

      Bug1035

      Synopsis

      Documentation

      data Foo #

      Constructors

      Bar

      data Bar #

      Constructors

      Foo

      foo :: () #

      A link to Bar

      \ No newline at end of file diff --git a/html-test/src/Bug1035.hs b/html-test/src/Bug1035.hs new file mode 100644 index 00000000..3516c08f --- /dev/null +++ b/html-test/src/Bug1035.hs @@ -0,0 +1,9 @@ +module Bug1035 where + +data Foo = Bar + +data Bar = Foo + +-- | A link to 'Bar' +foo :: () +foo = () -- cgit v1.2.3 From abb448ff120d6f09b6d070806de1d0eb334bc23b Mon Sep 17 00:00:00 2001 From: Alec Theriault 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') 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') 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') 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') 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') 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 10cfca4c660b682827e929ce0251341cb73efd14 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 2 May 2019 21:40:15 +0300 Subject: Redo ParseModuleHeader --- .../src/Haddock/Interface/ParseModuleHeader.hs | 218 ++++++++++++--------- 1 file changed, 125 insertions(+), 93 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 802ea773..32411e9e 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -11,7 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus) +import Control.Applicative (Alternative (..)) +import Control.Monad (ap) import Data.Char import DynFlags import Haddock.Parser @@ -26,34 +28,44 @@ import Haddock.Types parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) parseModuleHeader dflags pkgName str0 = let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) - - (_moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 - (maintainerOpt,str7) = getKey "Maintainer" str6 - (stabilityOpt,str8) = getKey "Stability" str7 - (portabilityOpt,str9) = getKey "Portability" str8 + kvs :: [(String, String)] + str1 :: String + + (kvs, str1) = maybe ([], str0) id $ runP fields str0 + + -- trim whitespaces + trim :: String -> String + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + getKey :: String -> Maybe String + getKey key = fmap trim (lookup key kvs) + + descriptionOpt = getKey "Description" + copyrightOpt = getKey "Copyright" + licenseOpt = getKey "License" + licenceOpt = getKey "Licence" + spdxLicenceOpt = getKey "SPDX-License-Identifier" + maintainerOpt = getKey "Maintainer" + stabilityOpt = getKey "Stability" + portabilityOpt = getKey "Portability" in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags pkgName str9) + }, parseParas dflags pkgName str1) + +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- --- | This function is how we read keys. +-- | The below is a small parser framework how we read keys. -- -- all fields in the header are optional and have the form -- @@ -72,78 +84,98 @@ parseModuleHeader dflags pkgName str0 = -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) - - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 - - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey _ _ [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str - - accept = isFirst || sufficientIndentation || allSpaces - - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False - - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 - - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) - - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | otherwise = ([],s) - - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | otherwise = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) - - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix _ [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | otherwise = Nothing + +data C = C {-# UNPACK #-} !Int Char + +newtype P a = P { unP :: [C] -> Maybe ([C], a) } + deriving Functor + +instance Applicative P where + pure x = P $ \s -> Just (s, x) + (<*>) = ap + +instance Monad P where + return = pure + m >>= k = P $ \s0 -> do + (s1, x) <- unP m s0 + unP (k x) s1 + +instance Alternative P where + empty = P $ \_ -> Nothing + a <|> b = P $ \s -> unP a s <|> unP b s + +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') + where + input' = concat + [ zipWith C [0..] l ++ [C (length l) '\n'] + | l <- lines input + ] + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of + [] -> 0 + C i _ : _ -> i + +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> + let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs) + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \s -> case s of + [] -> Nothing + (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) + | otherwise -> Nothing + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \s -> case s of + [] -> Nothing + (C _ c' : cs) | c == c' -> Just (cs, c) + | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where + go xs0@[] = ([], xs0) + go xs0@(x:xs) = case f x of + Just y -> let (ys, zs) = go xs in (y : ys, zs) + Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do + fn <- munch1 $ \_ c -> isAlpha c || c == '-' + skipSpaces + _ <- char ':' + skipSpaces + val <- munch $ \j c -> isSpace c || j > i + return (fn, val) + +fields :: P ([(String, String)], String) +fields = do + skipSpaces + i <- curInd + fs <- many (field i) + r <- rest + return (fs, r) + -- cgit v1.2.3 From bfe31a74f469b0e2c1a7360358698dcc32af9f5a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 2 May 2019 23:39:41 +0300 Subject: Comment C, which clarifies why e.g. ReadP is not enough --- haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 32411e9e..37813d16 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -85,6 +85,13 @@ parseModuleHeader dflags pkgName str0 = -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". +-- | 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- data C = C {-# UNPACK #-} !Int Char newtype P a = P { unP :: [C] -> Maybe ([C], a) } -- cgit v1.2.3 From 384577e862171bdedc9311c9d17f7ad3a4a33456 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 17 May 2019 11:23:40 -0400 Subject: Fix #1063 with better parenthesization logic for contexts The only other change in html/hoogle/hyperlinker output for the boot libraries that this caused is a fix to some Hoogle output for implicit params. ``` $ diff -r _build/docs/ old_docs diff -r _build/docs/html/libraries/base/base.txt old_docs/html/libraries/base/base.txt 13296c13296 < assertError :: (?callStack :: CallStack) => Bool -> a -> a --- > assertError :: ?callStack :: CallStack => Bool -> a -> a ``` --- haddock-api/src/Haddock/GhcUtils.hs | 6 ++- html-test/ref/Bug1063.html | 100 ++++++++++++++++++++++++++++++++++++ html-test/src/Bug1063.hs | 9 ++++ 3 files changed, 113 insertions(+), 2 deletions(-) create mode 100644 html-test/ref/Bug1063.html create mode 100644 html-test/src/Bug1063.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 29a52faf..5cc005cc 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -275,11 +275,13 @@ reparenTypePrec = go go p (HsKindSig x ty kind) = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) - = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) + = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) go p (HsForAllTy x tvs ty) = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) go p (HsQualTy x ctxt ty) - = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + = let p' [_] = PREC_CTX + p' _ = PREC_TOP -- parens will get added anyways later... + in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty) go p (HsFunTy x ty1 ty2) = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) diff --git a/html-test/ref/Bug1063.html b/html-test/ref/Bug1063.html new file mode 100644 index 00000000..a7555971 --- /dev/null +++ b/html-test/ref/Bug1063.html @@ -0,0 +1,100 @@ +Bug1063
      Safe HaskellSafe

      Bug1063

      Documentation

      class (c => d) => Implies c d #

      Instances

      Instances details
      (c => d) => Implies c d #
      Instance details

      Defined in Bug1063

      \ No newline at end of file diff --git a/html-test/src/Bug1063.hs b/html-test/src/Bug1063.hs new file mode 100644 index 00000000..c6d13a1f --- /dev/null +++ b/html-test/src/Bug1063.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +module Bug1063 where + +class (c => d) => Implies c d +instance (c => d) => Implies c d -- cgit v1.2.3 From 260e1e1be0bb23b4c6d474b36d57354441133ed1 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 26 May 2019 16:01:58 -0400 Subject: Remove Haddock's dependency on `Cabal` At this point, Haddock depended on Cabal-the-library solely for a verbosity parser (which misleadingly accepts all sorts of verbosity options that Haddock never uses). Now, the only dependency on Cabal is for `haddock-test` (which uses Cabal to locate the Haddock interface files of a couple boot libraries). --- haddock-api/haddock-api.cabal | 4 +--- haddock-api/src/Haddock/Interface.hs | 1 - haddock-api/src/Haddock/Options.hs | 3 +-- haddock-api/src/Haddock/Utils.hs | 25 ++++++++++++++++++++----- haddock.cabal | 1 - 5 files changed, 22 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 34d0bc30..c427e752 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -43,7 +43,6 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.12.0 - , Cabal ^>= 2.4.0 , ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 @@ -166,8 +165,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: Cabal ^>= 2.4 - , ghc ^>= 8.8 + build-depends: ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index e7d30fc7..336f122a 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -47,7 +47,6 @@ import Control.Exception (evaluate) import Data.List import qualified Data.Map as Map import qualified Data.Set as Set -import Distribution.Verbosity import Text.Printf import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index e314bbd0..510810b0 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -43,7 +43,6 @@ module Haddock.Options ( import qualified Data.Char as Char import Data.Version import Control.Applicative -import Distribution.Verbosity import FastString import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types @@ -332,7 +331,7 @@ sinceQualification flags = verbosity :: [Flag] -> Verbosity verbosity flags = case [ str | Flag_Verbosity str <- flags ] of - [] -> normal + [] -> Normal x:_ -> case parseVerbosity x of Left e -> throwE e Right v -> v diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index dda42cea..7673f02d 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -49,7 +49,7 @@ module Haddock.Utils ( MonadIO(..), -- * Logging - parseVerbosity, + parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, -- * System tools @@ -81,8 +81,6 @@ import System.Directory ( createDirectory, removeDirectoryRecursive ) import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath -import Distribution.Verbosity -import Distribution.ReadE #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -95,10 +93,27 @@ import MonadUtils ( MonadIO(..) ) -- * Logging -------------------------------------------------------------------------------- +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Eq, Ord, Enum, Bounded, Show) -parseVerbosity :: String -> Either String Verbosity -parseVerbosity = runReadE flagToVerbosity +silent, normal, verbose, deafening :: Verbosity +silent = Silent +normal = Normal +verbose = Verbose +deafening = Deafening +-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing. +parseVerbosity :: String -> Either String Verbosity +parseVerbosity "0" = Right Silent +parseVerbosity "1" = Right Normal +parseVerbosity "2" = Right Silent +parseVerbosity "3" = Right Deafening +parseVerbosity "silent" = return Silent +parseVerbosity "normal" = return Normal +parseVerbosity "verbose" = return Verbose +parseVerbosity "debug" = return Deafening +parseVerbosity "deafening" = return Deafening +parseVerbosity other = Left ("Can't parse verbosity " ++ other) -- | Print a message to stdout, if it is not too verbose out :: MonadIO m diff --git a/haddock.cabal b/haddock.cabal index 603a6a9b..078955fb 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -77,7 +77,6 @@ executable haddock deepseq, array, xhtml >= 3000.2 && < 3000.3, - Cabal >= 1.10, ghc-boot, ghc == 8.8.*, bytestring, -- 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') 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 9bbcd3859c9ea08b75e6964490e75236f4a73454 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Mon, 30 Sep 2019 20:12:42 -0500 Subject: Fix the ignore-exports option (#1082) The `ignore-exports` option has been broken since #688, as mentioned in https://github.com/haskell/haddock/pull/766#issue-172505043. This PR fixes it. --- haddock-api/src/Haddock/Interface/Create.hs | 9 ++--- html-test/Main.hs | 6 ---- html-test/ref/IgnoreExports.html | 54 +++++++++++++++++++++++++---- html-test/src/IgnoreExports.hs | 5 ++- 4 files changed, 56 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 463411b4..dd1d4eb3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -83,8 +83,9 @@ createInterface tm flags modMap instIfaceMap = do (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_exports = all_exports + , tcg_exports = all_exports0 }, md) = tm_internals_ tm + all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre -- The 'pkgName' is necessary to decide what package to mention in "@since" -- annotations. Not having it is not fatal though. @@ -111,9 +112,9 @@ createInterface tm flags modMap instIfaceMap = do let declsWithDocs = topDecls group_ exports0 = fmap (map (first unLoc)) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 + (all_exports, exports) + | OptIgnoreExports `elem` opts = (all_local_avails, Nothing) + | otherwise = (all_exports0, exports0) unrestrictedImportedMods -- module re-exports are only possible with diff --git a/html-test/Main.hs b/html-test/Main.hs index 26eefe4a..36e56d9a 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -54,12 +54,6 @@ ingoredTests = -- we need a reliable way to deduplicate here. -- Happens since PR #688. "B" - - -- ignore-exports flag broke with PR #688. We use - -- the Avails calculated by GHC now. Probably - -- requires a change to GHC to "ignore" a modules - -- export list reliably. - , "IgnoreExports" ] checkIgnore :: FilePath -> Bool diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html index eed12c00..8b3390ae 100644 --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -4,12 +4,14 @@ />IgnoreExportsSynopsis

      Documentation

      data Foo #

      documentation for Foo

      Constructors

      Bar

      Documentation for Bar

      foo :: :: Int #

      bar :: :: Int #

      +> \ No newline at end of file diff --git a/html-test/src/IgnoreExports.hs b/html-test/src/IgnoreExports.hs index 0321ad02..edb7c4c1 100644 --- a/html-test/src/IgnoreExports.hs +++ b/html-test/src/IgnoreExports.hs @@ -1,5 +1,8 @@ {-# OPTIONS_HADDOCK ignore-exports #-} -module IgnoreExports (foo) where +module IgnoreExports (Foo, foo) where + +-- | documentation for Foo +data Foo = Bar -- ^ Documentation for Bar -- | documentation for foo foo :: Int -- 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') 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') 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 2a5fc0ad50c857098558461434c29abd478ea0a1 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 23 Oct 2019 09:42:20 -0400 Subject: Reify oversaturated data family instances correctly (#1103) This fixes #1103 by adapting the corresponding patch for GHC (see https://gitlab.haskell.org/ghc/ghc/issues/17296 and https://gitlab.haskell.org/ghc/ghc/merge_requests/1877). --- haddock-api/src/Haddock/Convert.hs | 38 ++- html-test/ref/Bug1103.html | 556 +++++++++++++++++++++++++++++++++++++ html-test/src/Bug1103.hs | 24 ++ 3 files changed, 603 insertions(+), 15 deletions(-) create mode 100644 html-test/ref/Bug1103.html create mode 100644 html-test/src/Bug1103.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d22efc9a..5dc3a508 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -150,8 +150,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args typats = map (synifyType WithinType []) args_types_only - annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) - args_types_only typats + annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt @@ -162,7 +161,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where - fam_tvs = tyConVisibleTyVars tc + args_poly = tyConArgsPolyKinded tc synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) @@ -472,17 +471,26 @@ annotHsType True ty hs_ty in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty --- | For every type variable in the input, --- report whether or not the tv is poly-kinded. This is used to eventually --- feed into 'annotHsType'. -mkIsPolyTvs :: [TyVar] -> [Bool] -mkIsPolyTvs = map is_poly_tv +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs + ++ repeat True where - is_poly_tv tv = not $ + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ isEmptyVarSet $ filterVarSet isTyVar $ - tyCoVarsOfType $ - tyVarKind tv + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [TyCoBinder] + tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc --states of what to do with foralls: data SynifyTypeState @@ -787,8 +795,8 @@ synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types ts' = map (synifyType WithinType vs) ts - annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' - is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded cls_tycon synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family @@ -827,8 +835,8 @@ synifyFamInst fi opaque = do ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts - annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' - is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded fam_tc {- Note [Invariant: Never expand type synonyms] diff --git a/html-test/ref/Bug1103.html b/html-test/ref/Bug1103.html new file mode 100644 index 00000000..cc16017b --- /dev/null +++ b/html-test/ref/Bug1103.html @@ -0,0 +1,556 @@ +Bug1103
      Safe HaskellSafe

      Bug1103

      Documentation

      data family Foo1 :: Type -> Type #

      Instances

      Instances details
      data Foo1 Bool #
      Instance details

      Defined in Bug1103

      data Foo1 Bool = Foo1Bool
      data Foo1 (Maybe a) #
      Instance details

      Defined in Bug1103

      data Foo1 (Maybe a)

      data family Foo2 :: k -> Type #

      Instances

      Instances details
      data Foo2 (a :: Char) #
      Instance details

      Defined in Bug1103

      data Foo2 (a :: Char)
      data Foo2 Bool #
      Instance details

      Defined in Bug1103

      data Foo2 Bool = Foo2Bool
      data Foo2 (Maybe a :: Type) #
      Instance details

      Defined in Bug1103

      data Foo2 (Maybe a :: Type)
      data Foo2 (a :: Char -> Char) #
      Instance details

      Defined in Bug1103

      data Foo2 (a :: Char -> Char)

      data family Foo3 :: k #

      Instances

      Instances details
      data Foo3 #
      Instance details

      Defined in Bug1103

      data Foo3
      data Foo3 (a :: Char) #
      Instance details

      Defined in Bug1103

      data Foo3 (a :: Char)
      data Foo3 (a :: Char -> Char) #
      Instance details

      Defined in Bug1103

      data Foo3 (a :: Char -> Char)
      data Foo3 Bool #
      Instance details

      Defined in Bug1103

      data Foo3 Bool = Foo3Bool
      data Foo3 (Maybe a :: Type) #
      Instance details

      Defined in Bug1103

      data Foo3 (Maybe a :: Type)
      \ No newline at end of file diff --git a/html-test/src/Bug1103.hs b/html-test/src/Bug1103.hs new file mode 100644 index 00000000..1f387e62 --- /dev/null +++ b/html-test/src/Bug1103.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Bug1103 where + +import Data.Kind + +data family Foo1 :: Type -> Type +data instance Foo1 Bool = Foo1Bool +data instance Foo1 (Maybe a) + +data family Foo2 :: k -> Type +data instance Foo2 Bool = Foo2Bool +data instance Foo2 (Maybe a) +data instance Foo2 :: Char -> Type +data instance Foo2 :: (Char -> Char) -> Type where + +data family Foo3 :: k +data instance Foo3 +data instance Foo3 Bool = Foo3Bool +data instance Foo3 (Maybe a) +data instance Foo3 :: Char -> Type +data instance Foo3 :: (Char -> Char) -> Type where -- cgit v1.2.3 From b34ca2554a3440f092f585bb7fc1e9d4b2ca8616 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Thu, 17 Oct 2019 10:52:12 +0200 Subject: Define `XRec` for location information and get rid of `HasSrcSpan` In https://gitlab.haskell.org/ghc/ghc/merge_requests/1970 I propose a simpler way to encode location information into the GHC and Haddock AST while incurring no cost for e.g. TH which doesn't need location information. These are just changes that have to happen in lock step. --- haddock-api/src/Haddock/Types.hs | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c03ab385..b5659038 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -668,6 +668,8 @@ instance MonadIO ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- +type instance XRec DocNameI f = Located (f DocNameI) + type instance XForAllTy DocNameI = NoExtField type instance XQualTy DocNameI = NoExtField type instance XTyVar DocNameI = NoExtField @@ -748,19 +750,4 @@ type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField type instance XXConDeclField DocNameI = NoExtCon -type instance XXPat DocNameI = Located (Pat DocNameI) - -type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI -instance HasSrcSpan (LPat DocNameI) where - -- NB: The following chooses the behaviour of the outer location - -- wrapper replacing the inner ones. - composeSrcSpan (L sp p) = if sp == noSrcSpan - then p - else XPat (L sp (stripSrcSpanPat p)) - -- NB: The following only returns the top-level location, if any. - decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) - decomposeSrcSpan p = L noSrcSpan p - -stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI -stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p -stripSrcSpanPat p = p +type instance XXPat DocNameI = NoExtCon -- cgit v1.2.3 From e6ca100973c496cd98da3385594fa9a81320f7cb Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 30 Jan 2019 20:17:29 -0500 Subject: Changes from #14579 We now have a top-level `tyConAppNeedsKindSig` function, which means that we can delete lots of code in `Convert`. (cherry picked from commit cfd682c5fd03b099a3d78c44f9279faf56a0ac70) --- haddock-api/src/Haddock/Convert.hs | 27 +++++---------------------- 1 file changed, 5 insertions(+), 22 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5dc3a508..709e20d4 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,7 +28,6 @@ import ConLike import Data.Either (lefts, rights) import DataCon import FamInstEnv -import FV import HsSyn import Name import NameSet ( emptyNameSet ) @@ -45,8 +44,7 @@ import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import Unique ( getUnique ) -import Util ( chkAppend, compareLength, dropList, filterByList, filterOut - , splitAtList ) +import Util ( chkAppend,dropList, filterByList, filterOut, splitAtList ) import Var import VarSet @@ -547,7 +545,7 @@ synifyType _ vs (TyConApp tc tys) = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys + , tyConArity tc == tys_len = noLoc $ HsTupleTy noExt (case sort of BoxedTuple -> HsBoxedTuple @@ -604,32 +602,17 @@ synifyType _ vs (TyConApp tc tys) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) - vis_tys = filterOutInvisibleTypes tc tys - binders = tyConBinders tc - res_kind = tyConResKind tc + tys_len = length tys + vis_tys = filterOutInvisibleTypes tc tys maybe_sig :: LHsType GhcRn -> LHsType GhcRn maybe_sig ty' - | needs_kind_sig + | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' - needs_kind_sig :: Bool - needs_kind_sig - | GT <- compareLength tys binders - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAtList tys binders - result_kind = mkTyConKind remaining_binders res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injectiveVarsOfBinder dropped_binders - - in not (subVarSet result_vars dropped_vars) - synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 -- 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') 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 From 5bef8bd8a72465a0abb1753a8bbeb94634a9d698 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 22 Mar 2020 11:46:42 -0400 Subject: Clean up warnings * unused imports * imports of `Data.List` without import lists * missing `CompatPrelude` file in `.cabal` --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- haddock-api/src/Haddock/Interface.hs | 2 +- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 2 -- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 1 - haddock-api/src/Haddock/Utils/Json.hs | 2 +- haddock-library/haddock-library.cabal | 26 ++++++++++------------ haddock.cabal | 1 + 14 files changed, 22 insertions(+), 35 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1f98ef9c..b38d4047 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -27,10 +27,9 @@ import Haddock.Utils hiding (out) import GHC import Outputable -import NameSet import Data.Char -import Data.List +import Data.List (isPrefixOf, intercalate) import Data.Maybe import Data.Version diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index f2fb1041..63b12a14 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -38,7 +38,7 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List ( sort ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -517,12 +517,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = char '{' -ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) @@ -1063,7 +1057,6 @@ ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv ForallVis -> text "\\ " <> arrow unicode ForallInvis -> dot - ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c7ae15ca..b450dc94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,7 +36,6 @@ 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 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index edab4b16..0d7accfc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,7 +19,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Data.List +import Data.List (intersperse) import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index c2c0d733..24568235 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -44,7 +44,7 @@ import Haddock.Utils import Control.Monad import Control.Exception (evaluate) -import Data.List +import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map import qualified Data.Set as Set import Text.Printf diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 35f24ee5..685dca01 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -21,7 +21,7 @@ import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) -import Data.List +import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d5cbdaf5..b182a615 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -32,7 +32,7 @@ import Data.Bifunctor import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map) -import Data.List +import Data.List (find, foldl', sortBy) import Data.Maybe import Data.Ord import Control.Applicative diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 0b40ed3c..08a3c0f8 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,7 +22,7 @@ module Haddock.Interface.LexParseRn import Control.Arrow import Control.Monad import Data.Functor (($>)) -import Data.List +import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 72d063dc..0b122b07 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -22,14 +22,12 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import Outputable ( panic ) import RdrName (RdrName(Exact)) import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) -import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index b5be311a..3ce2fabb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -26,7 +26,7 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array import Data.IORef -import Data.List +import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 79673365..3eb702c9 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -65,7 +65,6 @@ import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs index e3c3dddc..2270a547 100644 --- a/haddock-api/src/Haddock/Utils/Json.hs +++ b/haddock-api/src/Haddock/Utils/Json.hs @@ -19,7 +19,7 @@ import Data.Char import Data.Int import Data.String import Data.Word -import Data.List +import Data.List (intersperse) import Data.Monoid import Data.ByteString.Builder (Builder) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index e58fe2ef..294ef5be 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -59,22 +59,20 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: - test - src - - cpp-options: - -DTEST + test + src other-modules: - Documentation.Haddock.Doc - Documentation.Haddock.Markup - Documentation.Haddock.Parser - Documentation.Haddock.Parser.Monad - Documentation.Haddock.Parser.Util - Documentation.Haddock.Parser.UtilSpec - Documentation.Haddock.ParserSpec - Documentation.Haddock.Types - Documentation.Haddock.Parser.Identifier + CompatPrelude + Documentation.Haddock.Doc + Documentation.Haddock.Markup + Documentation.Haddock.Parser + Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Util + Documentation.Haddock.Parser.UtilSpec + Documentation.Haddock.ParserSpec + Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.11.0 diff --git a/haddock.cabal b/haddock.cabal index 92fe249e..425ed454 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -87,6 +87,7 @@ executable haddock transformers other-modules: + CompatPrelude Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Identifier -- cgit v1.2.3 From 03dbfdd70186e484135ba1ea8d27672264cd9712 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 22 Mar 2020 20:10:52 -0400 Subject: Tentative 2.24 release Adjusted changelogs and versions in `.cabal` files in preparation for the upcoming release bundled with GHC 8.10. --- CHANGES.md | 7 +++++++ haddock-api/haddock-api.cabal | 6 +++--- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-library/CHANGES.md | 4 +++- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 4 ++-- 7 files changed, 18 insertions(+), 9 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/CHANGES.md b/CHANGES.md index 88656da4..b0600381 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +## Changes in 2.24.0 + + * Reify oversaturated data family instances correctly (#1103) + + * Removed the majority of Haddock's possible `panic` routes through + the TTG refactor to make extension variants empty + ## Changes in 2.23.0 * "Linuwial" is the new default theme (#721, #782, #949) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 8ad0ae64..0324fcd6 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.23.0 +version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -45,7 +45,7 @@ library build-depends: base ^>= 4.14.0 , ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.8.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -167,7 +167,7 @@ test-suite spec build-depends: ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.12 - , haddock-library ^>= 1.8.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.8 , QuickCheck >= 2.11 && < 2.14 diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b38d4047..b4a605f2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -260,7 +260,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k - tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" + tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 3ce2fabb..17be6fa1 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__ >= 809) && (__GLASGOW_HASKELL__ < 811) -binaryInterfaceVersion = 35 +binaryInterfaceVersion = 36 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index d112db45..5b400d7c 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,7 +1,9 @@ -## Changes in version 1.8.0.1 +## Changes in version 1.9.0 * Fix build-time regression for `base < 4.7` (#1119) + * Update parsing to strip whitespace from table cells (#1074) + ## Changes in version 1.8.0 * Support inline markup in markdown-style links (#875) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 294ef5be..57f45887 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: haddock-library -version: 1.8.0.1 +version: 1.9.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell diff --git a/haddock.cabal b/haddock.cabal index 425ed454..f01fe8fc 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: haddock -version: 2.23.0 +version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -144,7 +144,7 @@ executable haddock else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.23.0 + build-depends: haddock-api == 2.24.0 test-suite html-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From 2a2020c5331c593319bd196aadccdc46e7a3f779 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 28 Feb 2019 12:41:09 -0800 Subject: Disallow qualified uses of reserved identifiers This a GHC bug (https://gitlab.haskell.org/ghc/ghc/issues/14109) too, but it is a relatively easy fix in Haddock. Note that the fix must live in `haddock-api` instead of `haddock-library` because we can only really decide if an identifier is a reserved one by asking the GHC lexer. Fixes #952 --- haddock-api/src/Haddock/Parser.hs | 34 +++++++++++------- html-test/ref/Bug952.html | 76 +++++++++++++++++++++++++++++++++++++++ html-test/src/Bug952.hs | 5 +++ 3 files changed, 103 insertions(+), 12 deletions(-) create mode 100644 html-test/ref/Bug952.html create mode 100644 html-test/src/Bug952.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 6d5dc103..05f3c7f0 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -19,8 +20,10 @@ import Haddock.Types import DynFlags ( DynFlags ) import FastString ( fsLit ) -import Lexer ( mkPState, unP, ParseResult(POk) ) +import Lexer ( mkPState, unP, ParseResult(..) ) +import OccName ( occNameString ) import Parser ( parseIdentifier ) +import RdrName ( RdrName(Qual) ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) @@ -33,14 +36,21 @@ parseString d = P.overIdentifier (parseIdent d) . P.parseString parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns 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 (wrap (NsRdrName ns name)) - _ -> Nothing + case unP parseIdentifier (pstate str1) of + POk _ (L _ name) + -- Guards against things like 'Q.--', 'Q.case', etc. + -- See https://github.com/haskell/haddock/issues/952 and Trac #14109 + | Qual _ occ <- name + , PFailed{} <- unP parseIdentifier (pstate (occNameString occ)) + -> Nothing + | otherwise + -> Just (wrap (NsRdrName ns name)) + PFailed{} -> Nothing + where + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 + pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) diff --git a/html-test/ref/Bug952.html b/html-test/ref/Bug952.html new file mode 100644 index 00000000..bd301bcd --- /dev/null +++ b/html-test/ref/Bug952.html @@ -0,0 +1,76 @@ +Bug952
      Safe HaskellSafe-Inferred

      Bug952

      Synopsis

      Documentation

      foo :: () #

      See 'case', 'of', '--' compared to 'Q.case', 'Q.of', 'Q.--'

      diff --git a/html-test/src/Bug952.hs b/html-test/src/Bug952.hs new file mode 100644 index 00000000..09b365e4 --- /dev/null +++ b/html-test/src/Bug952.hs @@ -0,0 +1,5 @@ +module Bug952 where + +-- | See 'case', 'of', '--' compared to 'Q.case', 'Q.of', 'Q.--' +foo :: () +foo = () -- cgit v1.2.3 From e68cc0f05c102193660466d611640aec922bc9a9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 08:50:57 -0400 Subject: Remove unused `Haddock.Utils` functions * removed functions in `Haddock.Utils` that were not used anywhere (or exported from the `haddock-api` package) * moved GHC-specific utils from `Haddock.Utils` to `Haddock.GhcUtils` --- haddock-api/src/Haddock.hs | 1 + haddock-api/src/Haddock/Backends/Xhtml.hs | 4 + haddock-api/src/Haddock/GhcUtils.hs | 91 ++++++++++++++++++ haddock-api/src/Haddock/Interface.hs | 1 + haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 150 +----------------------------- 6 files changed, 102 insertions(+), 147 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index cf7bd857..0b5e33a3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -42,6 +42,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 9add4cae..d30312b7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -294,6 +294,10 @@ ppHtmlContents dflags odir doctitle _maybe_package ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + where + -- Extract a module's short description. + toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) + toInstalledDescription = fmap mkMeta . hmi_description . instInfo ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 6577e08f..77d6ec39 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -20,9 +20,11 @@ module Haddock.GhcUtils where import Control.Arrow import Data.Char ( isSpace ) +import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) +import BasicTypes ( PromotionFlag(..) ) import Exception import FV import Outputable ( Outputable, panic, showPpr ) @@ -253,6 +255,95 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" getGADTConTypeG (XConDecl nec) = noExtCon nec +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) + + +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn +-- Add the class context to a class-op signature +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) + -- The mkEmptySigWcType is suspicious + where + go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) + = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go (L loc ty) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) + | tv <- hsQTvExplicit tvs ] + + +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- + + +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn +restrictTo names (L loc decl) = L loc $ case decl of + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), + tcdATs = restrictATs names (tcdATs d) }) + _ -> decl + +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn +restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) + | DataType <- new_or_data + = defn { dd_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { dd_ND = DataType, dd_cons = [] } + [con] -> defn { dd_cons = [con] } + _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" + +restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] +restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] + where + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case con_args d of + PrefixCon _ -> Just d + RecCon fields + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + where + field_avail :: LConDeclField GhcRn -> Bool + field_avail (L _ (ConDeclField _ fs _ _)) + = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + field_avail (L _ (XConDeclField nec)) = noExtCon nec + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + + keep _ = Nothing + +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) + + +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] +restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] + + ------------------------------------------------------------------------------- -- * Parenthesization ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 24568235..6775cf2b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -43,6 +43,7 @@ import Haddock.Types import Haddock.Utils import Control.Monad +import Control.Monad.IO.Class ( liftIO ) import Control.Exception (evaluate) import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 17be6fa1..7b0f29f4 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -21,9 +21,9 @@ module Haddock.InterfaceFile ( import Haddock.Types -import Haddock.Utils hiding (out) import Control.Monad +import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Array import Data.IORef import Data.List (mapAccumR) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 3eb702c9..1d213420 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -13,15 +13,9 @@ ----------------------------------------------------------------------------- module Haddock.Utils ( - -- * Misc utilities - restrictTo, emptyHsQTvs, - toDescription, toInstalledDescription, - mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, - -- * Filename utilities moduleHtmlFile, moduleHtmlFile', contentsHtmlFile, indexHtmlFile, indexJsonFile, - moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, haddockJsFile, jsQuickJumpFile, quickJumpCssFile, @@ -32,7 +26,7 @@ module Haddock.Utils ( makeAnchorId, -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + getProgramName, bye, die, escapeStr, writeUtf8File, withTempDir, -- * HTML cross reference mapping @@ -45,9 +39,6 @@ module Haddock.Utils ( replace, spanWith, - -- * MTL stuff - MonadIO(..), - -- * Logging parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, @@ -61,23 +52,21 @@ import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types import Haddock.GhcUtils -import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Control.Monad ( liftM ) +import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) -import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit import System.Directory ( createDirectory, removeDirectoryRecursive ) -import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) +import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -85,8 +74,6 @@ import qualified System.FilePath.Posix as HtmlPath import qualified System.Posix.Internals #endif -import MonadUtils ( MonadIO(..) ) - -------------------------------------------------------------------------------- -- * Logging @@ -129,117 +116,14 @@ out progVerbosity msgVerbosity msg -------------------------------------------------------------------------------- --- | Extract a module's short description. -toDescription :: Interface -> Maybe (MDoc Name) -toDescription = fmap mkMeta . hmi_description . ifaceInfo - - --- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) -toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn --- Dubious, because the implicit binders are empty even --- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) - -addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn --- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious - where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) - = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) - add_ctxt (L loc preds) = L loc (extra_pred : preds) - -addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine - -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] -lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) - | tv <- hsQTvExplicit tvs ] - --------------------------------------------------------------------------------- --- * Making abstract declarations --------------------------------------------------------------------------------- - - -restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn -restrictTo names (L loc decl) = L loc $ case decl of - TyClD x d | isDataDecl d -> - TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD x d | isClassDecl d -> - TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) - _ -> decl - -restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn -restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) - | DataType <- new_or_data - = defn { dd_cons = restrictCons names cons } - | otherwise -- Newtype - = case restrictCons names cons of - [] -> defn { dd_ND = DataType, dd_cons = [] } - [con] -> defn { dd_cons = [con] } - _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" - -restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField _ fs _ _)) - = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_avail (L _ (XConDeclField nec)) = noExtCon nec - field_types flds = [ t | ConDeclField _ _ t _ <- flds ] - - keep _ = Nothing - -restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) - - -restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] - -emptyHsQTvs :: LHsQTyVars GhcRn --- This function is here, rather than in HsTypes, because it *renamed*, but --- does not necessarily have all the rigt kind variables. It is used --- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs" - , hsq_explicit = [] } - - -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. -------------------------------------------------------------------------------- - baseName :: ModuleName -> FilePath baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString @@ -266,13 +150,6 @@ indexHtmlFile = "doc-index.html" indexJsonFile = "doc-index.json" - -moduleIndexFrameName, mainFrameName, synopsisFrameName :: String -moduleIndexFrameName = "modules" -mainFrameName = "main" -synopsisFrameName = "synopsis" - - subIndexHtmlFile :: String -> String subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" where b | all isAlpha ls = ls @@ -346,7 +223,7 @@ quickJumpCssFile = "quick-jump.css" getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName +getProgramName = fmap (`withoutSuffix` ".bin") getProgName where str `withoutSuffix` suff | suff `isSuffixOf` str = take (length str - length suff) str | otherwise = str @@ -355,25 +232,6 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a bye s = putStr s >> exitSuccess - -dieMsg :: String -> IO () -dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - - -noDieMsg :: String -> IO () -noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) - - -mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] -mapSnd _ [] = [] -mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs - - -mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = liftM Just (f a) - - escapeStr :: String -> String escapeStr = escapeURIString isUnreserved -- cgit v1.2.3 From 730a2163245cf7aaf389458113e6fa338eca7865 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 12:04:16 -0400 Subject: Use TTG empty extensions to remove some `error`'s None of these error cases should ever have been reachable, so this is just a matter of leveraging the type system to assert this. * Use the `NoExtCon` and `noExtCon` to handle case matches for no extension constructors, instead of throwing an `error`. * Use the extension field of `HsSpliceTy` to ensure that this variant of `HsType` cannot exist in an `HsType DocNameI`. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 5 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 3 ++- haddock-api/src/Haddock/GhcUtils.hs | 15 +++++++-------- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 17 +++++------------ haddock-api/src/Haddock/Types.hs | 3 ++- 6 files changed, 21 insertions(+), 26 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 63b12a14..d52c136f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,6 +39,7 @@ import Data.Char import Control.Monad import Data.Maybe import Data.List ( sort ) +import Data.Void ( absurd ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -530,7 +531,7 @@ ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit +tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -1080,7 +1081,7 @@ ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u -ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index b450dc94..25669ca7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,6 +32,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe +import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) @@ -1215,7 +1216,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u q e = ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts -ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 77d6ec39..f600997a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -165,18 +165,17 @@ nubByName f ns = go emptyNameSet ns where y = f x + -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName -hsTyVarNameI (UserTyVar _ (L _ n)) = n -hsTyVarNameI (KindedTyVar _ (L _ n) _) = n -hsTyVarNameI (XTyVarBndr nec) = noExtCon nec - -hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName -hsLTyVarNameI = hsTyVarNameI . unLoc +-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) +hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n +hsTyVarBndrName (UserTyVar _ name) = unLoc name +hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name +hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] @@ -311,7 +310,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" +restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0b122b07..ce3878b8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -313,7 +313,7 @@ renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind ; return (L loc (KindedTyVar x (L lv n') kind')) } -renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" +renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -512,7 +512,7 @@ renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl) -renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" +renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 03cc1b7e..19b03596 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -9,6 +9,7 @@ module Haddock.Interface.Specialize ) where +import Haddock.GhcUtils ( hsTyVarBndrName ) import Haddock.Syb import Haddock.Types @@ -56,13 +57,9 @@ specialize specs = go spec_map0 -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn -specializeTyVarBndrs bndrs typs = - specialize $ zip bndrs' typs +specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where - bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar _ (L _ name)) = name - bname (KindedTyVar _ (L _ name) _) = name - bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -212,7 +209,7 @@ freeVariables = | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) -- | Make given type visually unambiguous. @@ -295,7 +292,7 @@ renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname renameBinder (KindedTyVar x lname lkind) = KindedTyVar x <$> located renameName lname <*> located renameType lkind -renameBinder (XTyVarBndr _) = error "haddock:renameBinder" +renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -349,7 +346,3 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar _ name) = unLoc name -tyVarName (KindedTyVar _ (L _ name) _) = name -tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 28e3caed..ec76fb72 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,6 +35,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) +import Data.Void (Void) import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) @@ -713,7 +714,7 @@ type instance XOpTy DocNameI = NoExtField type instance XParTy DocNameI = NoExtField type instance XIParamTy DocNameI = NoExtField type instance XKindSig DocNameI = NoExtField -type instance XSpliceTy DocNameI = NoExtField +type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` type instance XDocTy DocNameI = NoExtField type instance XBangTy DocNameI = NoExtField type instance XRecTy DocNameI = NoExtField -- cgit v1.2.3 From b33e4bebce0fb98acfc2c1f5efc370e95a061c86 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 12:28:48 -0400 Subject: Use `unLoc`/`noLoc` from GHC instead of `unL`/`reL` * `unL` is already defined by GHC as `unLoc` * `reL` is already defined by GHC as `noLoc` (in a safer way too!) * Condense `setOutputDir` and add a about exporting from GHC Fixes #978 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 24 ++++++------ haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +- haddock-api/src/Haddock/GhcUtils.hs | 53 ++++++++++---------------- haddock-api/src/Haddock/Interface/Create.hs | 18 ++++----- 5 files changed, 44 insertions(+), 57 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b4a605f2..63acb465 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -82,7 +82,7 @@ dropHsDocTy = f f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) f (HsParTy x a) = HsParTy x (g a) f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unL a + f (HsDocTy _ a _) = f $ unLoc a f x = x outHsType :: (OutputableBndrId p) @@ -215,7 +215,7 @@ ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : - concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) + concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where -- GHC gives out "data Bar =", we want to delete the equals. @@ -244,22 +244,22 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y) - apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) + funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y) + apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unL $ getConNames con + name = commaSeparate dflags . map unLoc $ getConNames con - resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat)) + resType = let c = HsTyVar noExtField NotPromoted (noLoc (tcdName dat)) as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) - in apps (map reL (c : as)) + in apps (map noLoc (c : as)) tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { }) @@ -267,8 +267,8 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) where f = [typeSig name (getGADTConTypeG con)] - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) - name = out dflags $ map unL $ getConNames con + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) + name = out dflags $ map unLoc $ getConNames con ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String] @@ -298,7 +298,7 @@ docWith dflags header d mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where - getDoc = maybe [] (return . fst) (lookup (unL n) subdocs) + getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d52c136f..647812f9 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -624,7 +624,7 @@ ppClassDecl instances doc subdocs text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True | L _ decl <- ats - , let name = unL . fdLName $ decl + , let name = unLoc . fdLName $ decl doc = lookupAnySubdoc name subdocs ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 25669ca7..ef0ba1b6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -492,7 +492,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats - , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ + , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ] ++ -- ToDo: add associated type defaults @@ -544,7 +544,7 @@ ppClassDecl summary links instances fixities loc d subdocs <+> subDefaults (maybeToList defTys) | at <- ats - , let name = unL . fdLName $ unL at + , let name = unLoc . fdLName $ unLoc at doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index f600997a..923516b6 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -319,8 +319,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] case con_args d of PrefixCon _ -> Just d RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but @@ -340,7 +340,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] +restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ] ------------------------------------------------------------------------------- @@ -443,18 +443,6 @@ reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c -------------------------------------------------------------------------------- --- * Located -------------------------------------------------------------------------------- - - -unL :: Located a -> a -unL (L _ x) = x - - -reL :: a -> Located a -reL = L undefined - ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -475,17 +463,17 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = case con_args con of - RecCon fields -> map (extFieldOcc . unL) $ - concatMap (cd_fld_names . unL) (unL fields) + RecCon fields -> map (extFieldOcc . unLoc) $ + concatMap (cd_fld_names . unLoc) (unLoc fields) _ -> [] instance Parent (TyClDecl GhcRn) where children d - | isDataDecl d = map unL $ concatMap (getConNames . unL) + | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = - map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] + map (unLoc . fdLName . unLoc) (tcdATs d) ++ + [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -495,13 +483,13 @@ family = getName &&& children familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] -familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) +familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. families :: TyClDecl GhcRn -> [(Name, [Name])] families d - | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) + | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] @@ -546,17 +534,16 @@ minimalDef n = do -- * DynFlags ------------------------------------------------------------------------------- - -setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags -setObjectDir f d = d{ objectDir = Just f} -setHiDir f d = d{ hiDir = Just f} -setHieDir f d = d{ hieDir = Just f} -setStubDir f d = d{ stubDir = Just f - , includePaths = addGlobalInclude (includePaths d) [f] } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. -setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f - +-- TODO: use `setOutputDir` from GHC +setOutputDir :: FilePath -> DynFlags -> DynFlags +setOutputDir dir dynFlags = + dynFlags { objectDir = Just dir + , hiDir = Just dir + , hieDir = Just dir + , stubDir = Just dir + , includePaths = addGlobalInclude (includePaths dynFlags) [dir] + , dumpDir = Just dir + } ------------------------------------------------------------------------------- -- * 'StringBuffer' and 'ByteString' diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b182a615..af006d03 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -461,14 +461,14 @@ subordinates instMap decl = case decl of dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where - cons = map unL $ (dd_cons dd) - constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c) + cons = map unLoc $ (dd_cons dd) + constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) + fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] - derivs = [ (instName, [unL doc], M.empty) + derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd @@ -585,13 +585,13 @@ sortByLoc = sortBy (comparing getLoc) -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unL . fst) +filterDecls = filter (isHandled . unLoc . fst) where isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True - isHandled (SigD _ d) = isUserLSig (reL d) + isHandled (SigD _ d) = isUserLSig (noLoc d) isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD {}) = True @@ -677,7 +677,7 @@ mkExportItems return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= \case + findNamedDoc str [ unLoc d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr @@ -725,13 +725,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unL decl) + let declNames = getMainDeclBinder (unLoc decl) in case () of _ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, - Just p <- find isExported (parents t $ unL decl) -> + Just p <- find isExported (parents t $ unLoc decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++ -- cgit v1.2.3 From 8edc70fef3f3a54238d981153a6ac42b2d7f0bde Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 13:12:50 -0400 Subject: Cleanup up GHC flags in `.cabal` files * enable more useful warning flags in `haddock-api`, handle the new warnings generated * remove `-fwarn-tabs` (now we'd use `-Wtabs`, but this has been in `-Wall` for a while now) --- haddock-api/haddock-api.cabal | 12 ++++++++---- haddock-api/src/Haddock/Interface/Specialize.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 5 files changed, 12 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 54255e09..4abfd984 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -63,10 +63,14 @@ library hs-source-dirs: src - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 - ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances + ghc-options: -funbox-strict-fields -O2 + -Wall + -Wcompat + -Widentities + -Wredundant-constraints + -Wnoncanonical-monad-instances + -Wmissing-home-modules + exposed-modules: Documentation.Haddock diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 19b03596..492818bd 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -295,7 +295,7 @@ renameBinder (KindedTyVar x lname lkind) = renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic. -renameName :: (Eq name, SetName name) => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 7b0f29f4..cb60fb00 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -158,7 +158,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m +nameCacheFromGhc :: GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 1a06d0e5..24ca920f 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -44,7 +44,7 @@ common lib-defaults , text ^>= 1.2.3.0 , parsec ^>= 3.1.13.0 - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs + ghc-options: -funbox-strict-fields -Wall if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances diff --git a/haddock.cabal b/haddock.cabal index f01fe8fc..1d6ad180 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -62,7 +62,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded + ghc-options: -funbox-strict-fields -Wall -O2 -threaded -- haddock typically only supports a single GHC major version build-depends: -- cgit v1.2.3 From 5dc3866928759fcaf6b31d1598051781389a01d4 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 14:12:48 -0400 Subject: Disallow links in section headers This is quite straightforward to implement, since we already had a function `docToHtmlNoAnchors` (which we used to generate the link in the sidebar "Contents"). This breaks test `Bug387`, but that test case has aged badly: we now automatically generate anchors for all headings, so manually adding an anchor in a section makes no sense. Nested anchors are, as pointed out in #1054, disallowed by the HTML standard. Fixes #1054 --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- html-test/ref/Bug1054.html | 90 +++++++++++++++++++++++ html-test/ref/Bug387.html | 118 ------------------------------ html-test/src/Bug1054.hs | 5 ++ html-test/src/Bug387.hs | 12 --- 5 files changed, 96 insertions(+), 131 deletions(-) create mode 100644 html-test/ref/Bug1054.html delete mode 100644 html-test/ref/Bug387.html create mode 100644 html-test/src/Bug1054.hs delete mode 100644 html-test/src/Bug387.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d30312b7..e3d4e8ca 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -681,7 +681,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) + = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ _ qual (ExportNoDecl y []) diff --git a/html-test/ref/Bug1054.html b/html-test/ref/Bug1054.html new file mode 100644 index 00000000..df3fae0a --- /dev/null +++ b/html-test/ref/Bug1054.html @@ -0,0 +1,90 @@ +Bug1054
      Safe HaskellSafe-Inferred

      Bug1054

      Synopsis
      diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html deleted file mode 100644 index 12887a83..00000000 --- a/html-test/ref/Bug387.html +++ /dev/null @@ -1,118 +0,0 @@ -Bug387
      Safe HaskellSafe-Inferred

      Bug387

      Synopsis
      diff --git a/html-test/src/Bug1054.hs b/html-test/src/Bug1054.hs new file mode 100644 index 00000000..c699f1fb --- /dev/null +++ b/html-test/src/Bug1054.hs @@ -0,0 +1,5 @@ +module Bug1054 where + +-- * Header with 'foo' link + +foo = () diff --git a/html-test/src/Bug387.hs b/html-test/src/Bug387.hs deleted file mode 100644 index d9fed34e..00000000 --- a/html-test/src/Bug387.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Bug387 - ( -- * Section1#a:section1# - test1 - -- * Section2#a:section2# - , test2 - ) where - -test1 :: Int -test1 = 223 - -test2 :: Int -test2 = 42 -- cgit v1.2.3 From 87fbc11227347da805a3d2158d462514438ca742 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sun, 5 Apr 2020 11:48:39 -0400 Subject: Fix #1050 by filtering out invisible AppTy arguments This makes the `synifyType` case for `AppTy` more intelligent by taking into consideration the visibilities of each `AppTy` argument and filtering out any invisible arguments, as they aren't intended to be displayed in the source code. (See #1050 for an example of what can happen if you fail to filter these out.) Along the way, I noticed that a special `synifyType` case for `AppTy t1 (CoercionTy {})` could be consolidated with the case below it, so I took the opportunity to tidy this up. --- haddock-api/src/Haddock/Convert.hs | 13 +++-- html-test/ref/Bug1050.html | 110 +++++++++++++++++++++++++++++++++++++ html-test/src/Bug1050.hs | 11 ++++ 3 files changed, 129 insertions(+), 5 deletions(-) create mode 100644 html-test/ref/Bug1050.html create mode 100644 html-test/src/Bug1050.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d5fa3667..1a1e95bd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -612,11 +612,14 @@ synifyType _ vs (TyConApp tc tys) in noLoc $ HsKindSig noExtField ty' full_kind' | otherwise = ty' -synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 -synifyType _ vs (AppTy t1 t2) = let - s1 = synifyType WithinType vs t1 - s2 = synifyType WithinType vs t2 - in noLoc $ HsAppTy noExtField s1 s2 +synifyType _ vs ty@(AppTy {}) = let + (ty_head, ty_args) = splitAppTys ty + ty_head' = synifyType WithinType vs ty_head + ty_args' = map (synifyType WithinType vs) $ + filterOut isCoercionTy $ + filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) + ty_args + in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1 diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html new file mode 100644 index 00000000..2d938656 --- /dev/null +++ b/html-test/ref/Bug1050.html @@ -0,0 +1,110 @@ +Bug1050
      Safe HaskellSafe-Inferred

      Bug1050

      Documentation

      newtype T :: (forall k. k -> Type) -> forall k. k -> Type where #

      Constructors

      MkT :: forall (f :: forall k. k -> Type) k (a :: k). f a -> T f a 

      mkT :: forall k (f :: forall k1. k1 -> Type) (a :: k). f a -> T f a #

      diff --git a/html-test/src/Bug1050.hs b/html-test/src/Bug1050.hs new file mode 100644 index 00000000..ea293e6e --- /dev/null +++ b/html-test/src/Bug1050.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +module Bug1050 where + +import Data.Kind + +newtype T :: (forall k. k -> Type) -> (forall k. k -> Type) where + MkT :: forall (f :: forall k. k -> Type) k (a :: k). f a -> T f a + +mkT = MkT -- cgit v1.2.3 From d8aaaba9414b149fa7941d364b6d4a3fbcc1a520 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Fri, 10 Apr 2020 04:15:01 +0300 Subject: Recode Doc to Json. (#1159) * Recode Doc to Json. * More descriptive field labels. --- haddock-api/src/Haddock/Interface/Json.hs | 167 +++++++++++++++++++++++++++++- 1 file changed, 162 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index a9834fa0..2cacabe1 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -13,7 +13,6 @@ import Outputable import Control.Arrow import Data.Map (Map) -import Data.Bifunctor import qualified Data.Map as Map import Haddock.Types @@ -58,14 +57,172 @@ jsonMap f g = jsonObject . map (f *** g) . Map.toList jsonMDoc :: MDoc Name -> JsonDoc jsonMDoc MetaDoc{..} = jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) - , ("doc", jsonDoc _doc) + , ("document", jsonDoc _doc) ] +showModName :: Wrap (ModuleName, OccName) -> String +showModName = showWrapped (moduleNameString . fst) + +showName :: Wrap Name -> String +showName = showWrapped nameStableString + + jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap showModName showName doc)) + +jsonDoc DocEmpty = jsonObject + [ ("tag", jsonString "DocEmpty") ] + +jsonDoc (DocAppend x y) = jsonObject + [ ("tag", jsonString "DocAppend") + , ("first", jsonDoc x) + , ("second", jsonDoc y) + ] + +jsonDoc (DocString s) = jsonObject + [ ("tag", jsonString "DocString") + , ("string", jsonString s) + ] + +jsonDoc (DocParagraph x) = jsonObject + [ ("tag", jsonString "DocParagraph") + , ("document", jsonDoc x) + ] + +jsonDoc (DocIdentifier name) = jsonObject + [ ("tag", jsonString "DocIdentifier") + , ("name", jsonString (showName name)) + ] + +jsonDoc (DocIdentifierUnchecked modName) = jsonObject + [ ("tag", jsonString "DocIdentifierUnchecked") + , ("modName", jsonString (showModName modName)) + ] + +jsonDoc (DocModule s) = jsonObject + [ ("tag", jsonString "DocModule") + , ("string", jsonString s) + ] + +jsonDoc (DocWarning x) = jsonObject + [ ("tag", jsonString "DocWarning") + , ("document", jsonDoc x) + ] + +jsonDoc (DocEmphasis x) = jsonObject + [ ("tag", jsonString "DocEmphasis") + , ("document", jsonDoc x) + ] + +jsonDoc (DocMonospaced x) = jsonObject + [ ("tag", jsonString "DocMonospaced") + , ("document", jsonDoc x) + ] + +jsonDoc (DocBold x) = jsonObject + [ ("tag", jsonString "DocBold") + , ("document", jsonDoc x) + ] + +jsonDoc (DocUnorderedList xs) = jsonObject + [ ("tag", jsonString "DocUnorderedList") + , ("documents", jsonArray (fmap jsonDoc xs)) + ] + +jsonDoc (DocOrderedList xs) = jsonObject + [ ("tag", jsonString "DocOrderedList") + , ("documents", jsonArray (fmap jsonDoc xs)) + ] + +jsonDoc (DocDefList xys) = jsonObject + [ ("tag", jsonString "DocDefList") + , ("definitions", jsonArray (fmap jsonDef xys)) + ] where - showModName = showWrapped (moduleNameString . fst) - showName = showWrapped nameStableString + jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)] + +jsonDoc (DocCodeBlock x) = jsonObject + [ ("tag", jsonString "DocCodeBlock") + , ("document", jsonDoc x) + ] + +jsonDoc (DocHyperlink hyperlink) = jsonObject + [ ("tag", jsonString "DocHyperlink") + , ("hyperlink", jsonHyperlink hyperlink) + ] + where + jsonHyperlink Hyperlink{..} = jsonObject + [ ("hyperlinkUrl", jsonString hyperlinkUrl) + , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel) + ] + +jsonDoc (DocPic picture) = jsonObject + [ ("tag", jsonString "DocPic") + , ("picture", jsonPicture picture) + ] + where + jsonPicture Picture{..} = jsonObject + [ ("pictureUrl", jsonString pictureUri) + , ("pictureLabel", jsonMaybe jsonString pictureTitle) + ] + +jsonDoc (DocMathInline s) = jsonObject + [ ("tag", jsonString "DocMathInline") + , ("string", jsonString s) + ] + +jsonDoc (DocMathDisplay s) = jsonObject + [ ("tag", jsonString "DocMathDisplay") + , ("string", jsonString s) + ] + +jsonDoc (DocAName s) = jsonObject + [ ("tag", jsonString "DocAName") + , ("string", jsonString s) + ] + +jsonDoc (DocProperty s) = jsonObject + [ ("tag", jsonString "DocProperty") + , ("string", jsonString s) + ] + +jsonDoc (DocExamples examples) = jsonObject + [ ("tag", jsonString "DocExamples") + , ("examples", jsonArray (fmap jsonExample examples)) + ] + where + jsonExample Example{..} = jsonObject + [ ("exampleExpression", jsonString exampleExpression) + , ("exampleResult", jsonArray (fmap jsonString exampleResult)) + ] + +jsonDoc (DocHeader header) = jsonObject + [ ("tag", jsonString "DocHeader") + , ("header", jsonHeader header) + ] + where + jsonHeader Header{..} = jsonObject + [ ("headerLevel", jsonInt headerLevel) + , ("headerTitle", jsonDoc headerTitle) + ] + +jsonDoc (DocTable table) = jsonObject + [ ("tag", jsonString "DocTable") + , ("table", jsonTable table) + ] + where + jsonTable Table{..} = jsonObject + [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows)) + , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows)) + ] + + jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells) + + jsonTableCell TableCell{..} = jsonObject + [ ("tableCellColspan", jsonInt tableCellColspan) + , ("tableCellRowspan", jsonInt tableCellRowspan) + , ("tableCellContents", jsonDoc tableCellContents) + ] + jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString -- cgit v1.2.3 From 8d83110789def9207463a035fa766b78ebf5fdd9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 15 Apr 2020 09:21:09 -0400 Subject: Prune docstrings that are never rendered When first creating a Haddock interface, trim `ifaceDocMap` and `ifaceArgMap` to not include docstrings that can never appear in the final output. Besides checking with GHC which names are exported, we also need to keep all the docs attached to instance declarations (it is much tougher to detect when an instance is fully private). This change means: * slightly smaller interface files (7% reduction on boot libs) * slightly less work to do processing docstrings that aren't used * no warnings in Haddock's output about private docstrings (see #1070) I've tested manually that this does not affect any of the boot library generated docs (the only change in output was some small re-ordering in a handful of instance lists). This should mean no docstrings have been incorrectly dropped. --- haddock-api/src/Haddock/Interface/Create.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index af006d03..f29f576e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -31,6 +31,7 @@ import Haddock.Interface.LexParseRn import Data.Bifunctor import Data.Bitraversable import qualified Data.Map as M +import qualified Data.Set as S import Data.Map (Map) import Data.List (find, foldl', sortBy) import Data.Maybe @@ -165,6 +166,18 @@ createInterface tm flags modMap instIfaceMap = do modWarn <- liftErrMsg (moduleWarning dflags gre warnings) + -- Prune the docstring 'Map's to keep only docstrings that are not private. + -- + -- Besides all the names that GHC has told us this module exports, we also + -- keep the docs for locally defined class instances. This is more names than + -- we need, but figuring out which instances are fully private is tricky. + -- + -- We do this pruning to avoid having to rename, emit warnings, and save + -- docstrings which will anyways never be rendered. + let !localVisibleNames = S.fromList (localInsts ++ exportedNames) + !prunedDocMap = M.restrictKeys docMap localVisibleNames + !prunedArgMap = M.restrictKeys argMap localVisibleNames + return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig @@ -173,8 +186,8 @@ createInterface tm flags modMap instIfaceMap = do , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap + , ifaceDocMap = prunedDocMap + , ifaceArgMap = prunedArgMap , ifaceRnDocMap = M.empty , ifaceRnArgMap = M.empty , ifaceExportItems = prunedExportItems -- cgit v1.2.3 From 83f0fa0b6218c34898337bf41072ee5fedec1bde Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 15 Apr 2020 09:56:55 -0400 Subject: Don't warn about missing links in miminal sigs When renaming the Haddock interface, never emit warnings when renaming a minimal signature. Also added some documention around `renameInterface`. Minimal signatures intentionally include references to potentially un-exported methods (see the discussion in #330), so it is expected that they will not always have a link destination. On the principle that warnings should always be resolvable, this shouldn't produce a warning. See #1070. --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 15 ++++++++++++++- 2 files changed, 17 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index f29f576e..0f24afaa 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -188,10 +188,10 @@ createInterface tm flags modMap instIfaceMap = do , ifaceOptions = opts , ifaceDocMap = prunedDocMap , ifaceArgMap = prunedArgMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty + , ifaceRnDocMap = M.empty -- Filled in `renameInterface` + , ifaceRnArgMap = M.empty -- Filled in `renameInterface` , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] + , ifaceRnExportItems = [] -- Filled in `renameInterface` , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index ce3878b8..97f128d7 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -31,6 +31,14 @@ import Control.Monad hiding (mapM) import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) +-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to +-- 'DocName'. +-- +-- What this really boils down to is: for each 'Name', figure out which of the +-- modules that export the name is the preferred place to link to. +-- +-- The renamed output gets written into fields in the Haddock interface record +-- that were previously left empty. renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface renameInterface dflags renamingEnv warnings iface = @@ -128,6 +136,11 @@ lookupRn name = RnM $ \lkp -> (False,maps_to) -> (maps_to, (name :)) (True, maps_to) -> (maps_to, id) +-- | Look up a 'Name' in the renaming environment, but don't warn if you don't +-- find the name. Prefer to use 'lookupRn' whenever possible. +lookupRnNoWarn :: Name -> RnM DocName +lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id) + -- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. -- Returns the renamed value along with a list of `Name`'s that could not be -- renamed because they weren't in the environment. @@ -532,7 +545,7 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ src (L l s) -> do - s' <- traverse renameL s + s' <- traverse (traverse lookupRnNoWarn) s return $ MinimalSig noExtField src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -- cgit v1.2.3 From 5bc5016a14bc872a8315cddc629f8171a9ccd62e Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 21 Apr 2020 10:53:28 -0400 Subject: Fallback to `hiDecl` when `extractDecl` fails Sometimes, the declaration being exported is a subdecl (for instance, a record accessor getting exported at the top-level). For these cases, Haddock has to find a way to produce some synthetic sensible top-level declaration. This is done with `extractDecl`. As is shown by #1067, this is sometimes impossible to do just at a syntactic level (for instance when the subdecl is re-exported). In these cases, the only sensible thing to do is to try to reify a declaration based on a GHC `TyThing` via `hiDecl`. --- haddock-api/src/Haddock/Interface/Create.hs | 114 +++++++++++++++++----------- html-test/ref/Bug1067A.html | 114 ++++++++++++++++++++++++++++ html-test/ref/Bug1067B.html | 84 ++++++++++++++++++++ html-test/src/Bug1067A.hs | 9 +++ html-test/src/Bug1067B.hs | 4 + 5 files changed, 280 insertions(+), 45 deletions(-) create mode 100644 html-test/ref/Bug1067A.html create mode 100644 html-test/ref/Bug1067B.html create mode 100644 html-test/src/Bug1067A.hs create mode 100644 html-test/src/Bug1067B.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 0f24afaa..5a58e1ac 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -793,11 +793,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames _ -> return [] + -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails + availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn) + availDecl declName parentDecl = + case extractDecl declMap declName parentDecl of + Right d -> pure d + Left err -> do + synifiedDeclOpt <- hiDecl dflags declName + case synifiedDeclOpt of + Just synifiedDecl -> pure synifiedDecl + Nothing -> O.pprPanic "availExportItem" (O.text err) + availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do + extractedDecl <- availDecl (availName avail) decl + -- bundled pattern synonyms only make sense if the declaration is -- exported (otherwise there would be nothing to bundle to) bundledPatSyns <- findBundledPatterns avail @@ -813,8 +826,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames ] return [ ExportDecl { - expItemDecl = restrictTo (fmap fst subs) - (extractDecl declMap (availName avail) decl) + expItemDecl = restrictTo (fmap fst subs) extractedDecl , expItemPats = bundledPatSyns , expItemMbDoc = doc , expItemSubDocs = subs @@ -824,18 +836,18 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames } ] - | otherwise = - return [ ExportDecl { - expItemDecl = extractDecl declMap sub decl + | otherwise = for subs $ \(sub, sub_doc) -> do + extractedDecl <- availDecl sub decl + + return ( ExportDecl { + expItemDecl = extractedDecl , expItemPats = [] , expItemMbDoc = sub_doc , expItemSubDocs = [] , expItemInstances = [] , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] , expItemSpliced = False - } - | (sub, sub_doc) <- subs - ] + } ) exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet @@ -910,6 +922,7 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m +-- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t @@ -1053,20 +1066,30 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam isSigD (L _ SigD{}) = True isSigD _ = False + -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +-- +-- This function looks through the declarations in this module to try to find +-- the one with the right name. +extractDecl + :: DeclMap -- ^ all declarations in the file + -> Name -- ^ name of the declaration to extract + -> LHsDecl GhcRn -- ^ parent declaration + -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl - | name `elem` getMainDeclBinder (unLoc decl) = decl + | name `elem` getMainDeclBinder (unLoc decl) = pure decl | otherwise = case unLoc decl of - TyClD _ d@ClassDecl {} -> + TyClD _ d@ClassDecl { tcdLName = L _ clsNm + , tcdSigs = clsSigs + , tcdATs = clsATs } -> let matchesMethod = [ lsig - | lsig <- tcdSigs d + | lsig <- clsSigs , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig @@ -1074,51 +1097,54 @@ extractDecl declMap name decl matchesAssociatedType = [ lfam_decl - | lfam_decl <- tcdATs d + | lfam_decl <- clsATs , name == unLoc (fdLName (unLoc lfam_decl)) ] -- TODO: document fixity in case (matchesMethod, matchesAssociatedType) of - ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) - L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD noExtField sig) - (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl)) + ([s0], _) -> let tyvar_names = tyClDeclTyVars d + L pos sig = addClassContext clsNm tyvar_names s0 + in pure (L pos (SigD noExtField sig)) + (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl))) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap -> extractDecl declMap name famInstDecl - _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" - O.$$ O.nest 4 (O.ppr d) - O.$$ O.text "Matches:" - O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) - TyClD _ d@DataDecl {} -> - let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in if isDataConName name - then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) - else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + _ -> Left (concat [ "Ambiguous decl for ", getOccString name + , " in class ", getOccString clsNm ]) + + TyClD _ d@DataDecl { tcdLName = L _ dataNm + , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do + let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d)) + lsig <- if isDataConName name + then extractPatternSyn name dataNm ty_args dataCons + else extractRecSel name dataNm ty_args dataCons + pure (SigD noExtField <$> lsig) + TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_tycon = L _ n - , feqn_pats = tys - , feqn_rhs = defn }}))) -> - if isDataConName name - then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) - else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) + FamEqn { feqn_tycon = L _ famName + , feqn_pats = ty_args + , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do + lsig <- if isDataConName name + then extractPatternSyn name famName ty_args dataCons + else extractRecSel name famName ty_args dataCons + pure (SigD noExtField <$> lsig) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_rhs = dd + FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons } } })) <- insts - , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) + , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons) ] in case matches of [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) - _ -> error "internal: extractDecl (ClsInstD)" + _ -> Left "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts @@ -1130,16 +1156,14 @@ extractDecl declMap name decl ] in case matches of [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) - _ -> error "internal: extractDecl (ClsInstD)" - _ -> O.pprPanic "extractDecl" $ - O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" - O.$$ O.nest 4 (O.ppr decl) + _ -> Left "internal: extractDecl (ClsInstD)" + _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> error "extractPatternSyn: constructor pattern not found" - con:_ -> extract <$> con + [] -> Left "extractPatternSyn: constructor pattern not found" + con:_ -> pure (extract <$> con) where matches :: LConDecl GhcRn -> Bool matches (L _ con) = nm `elem` (unLoc <$> getConNames con) @@ -1170,13 +1194,13 @@ extractPatternSyn nm t tvs cons = mkAppTyArg f (HsArgPar _) = HsParTy noExtField f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] - -> LSig GhcRn -extractRecSel _ _ _ [] = error "extractRecSel: selector not found" + -> Either ErrMsg (LSig GhcRn) +extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))) + pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/html-test/ref/Bug1067A.html b/html-test/ref/Bug1067A.html new file mode 100644 index 00000000..96b8d495 --- /dev/null +++ b/html-test/ref/Bug1067A.html @@ -0,0 +1,114 @@ +Bug1067A
      Safe HaskellSafe-Inferred

      Bug1067A

      Synopsis

      Documentation

      data Foo where #

      A foo

      Bundled Patterns

      pattern P :: Foo

      A pattern

      diff --git a/html-test/ref/Bug1067B.html b/html-test/ref/Bug1067B.html new file mode 100644 index 00000000..f3bf821a --- /dev/null +++ b/html-test/ref/Bug1067B.html @@ -0,0 +1,84 @@ +Bug1067B
      Safe HaskellSafe-Inferred

      Bug1067B

      Synopsis

      Documentation

      pattern P :: Foo #

      A pattern

      diff --git a/html-test/src/Bug1067A.hs b/html-test/src/Bug1067A.hs new file mode 100644 index 00000000..57ab60b0 --- /dev/null +++ b/html-test/src/Bug1067A.hs @@ -0,0 +1,9 @@ +{-# language PatternSynonyms #-} +module Bug1067A ( Foo(P) ) where + +-- | A foo +data Foo = Foo + +-- | A pattern +pattern P :: Foo +pattern P = Foo diff --git a/html-test/src/Bug1067B.hs b/html-test/src/Bug1067B.hs new file mode 100644 index 00000000..f1a814df --- /dev/null +++ b/html-test/src/Bug1067B.hs @@ -0,0 +1,4 @@ +{-# language PatternSynonyms #-} +module Bug1067B ( pattern P ) where + +import Bug1067A -- cgit v1.2.3 From 3c9e8081228ffcc38c760a6d9501a626071a5105 Mon Sep 17 00:00:00 2001 From: Iñaki <1238558+garetxe@users.noreply.github.com> Date: Sat, 25 Apr 2020 23:38:11 +0100 Subject: Add support for custom section anchors (#1179) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This allows to have stable anchors for groups, even if the set of groups in the documentation is altered. The syntax for setting the anchor of a group is -- * Group name #desiredAnchor# Which will produce an html anchor of the form '#g:desiredAnchor' Co-authored-by: Iñaki García Etxebarria --- doc/markup.rst | 15 +++++ haddock-api/src/Haddock/Backends/Xhtml.hs | 8 ++- html-test/ref/SectionLabels.html | 91 +++++++++++++++++++++++++++++++ html-test/src/SectionLabels.hs | 8 +++ 4 files changed, 121 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/SectionLabels.html create mode 100644 html-test/src/SectionLabels.hs (limited to 'haddock-api/src/Haddock') diff --git a/doc/markup.rst b/doc/markup.rst index 08510804..af71e7c7 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -508,6 +508,19 @@ on, where the number of ``*``\ s indicates the level of the heading If you use section headings, then Haddock will generate a table of contents at the top of the module documentation for you. +By default, when generating HTML documentation Haddock will create an +anchor to each section of the form ``#g:n``, where ``n`` is an integer +that might change as you add new section headings. If you want to +create stable links, you can add an explicit anchor (see +:ref:`anchors`) after the section heading: :: + + module Foo ( + -- * Classes #classes# + C(..) + ) where + +This will create an HTML anchor ``#g:classes`` to the section. + The alternative style of placing the commas at the beginning of each line is also supported. e.g.: :: @@ -1150,6 +1163,8 @@ Inspired by reSTs grid tables Haddock supports a complete table representation v -- | body row 4 | | \] | -- +------------------------+------------+---------------------+ +.. _anchors: + Anchors ~~~~~~~ diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index e3d4e8ca..4e87d0be 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -672,10 +672,16 @@ numberSectionHeadings = go 1 where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es + = case collectAnchors doc of + [] -> ExportGroup lev (show n) doc : go (n+1) es + (a:_) -> ExportGroup lev a doc : go (n+1) es go n (other:es) = other : go n es + collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String] + collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b + collectAnchors (DocAName a) = [a] + collectAnchors _ = [] processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html diff --git a/html-test/ref/SectionLabels.html b/html-test/ref/SectionLabels.html new file mode 100644 index 00000000..4581082e --- /dev/null +++ b/html-test/ref/SectionLabels.html @@ -0,0 +1,91 @@ + +SectionLabels
      Safe HaskellSafe-Inferred

      SectionLabels

      Synopsis
      diff --git a/html-test/src/SectionLabels.hs b/html-test/src/SectionLabels.hs new file mode 100644 index 00000000..560bafa4 --- /dev/null +++ b/html-test/src/SectionLabels.hs @@ -0,0 +1,8 @@ +module SectionLabels + ( + -- * Section heading#custom# + n + ) where + +n :: Int +n = 3 -- cgit v1.2.3 From 8551fcd2e3e0d1a34fc09233f35a62d537df7cc1 Mon Sep 17 00:00:00 2001 From: Willem Van Onsem <3482343+KommuSoft@users.noreply.github.com> Date: Mon, 25 May 2020 18:23:01 +0200 Subject: Use floor over round to calculate the percentage (#1195) If we compile documentation where only a small fraction is undocumented, it is misleading to see 100% coverage - 99% is more intuitive. Fixes #1194 --- haddock-api/src/Haddock/Interface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 6775cf2b..66e0bedc 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -182,7 +182,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + percentage = floor (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int modString = moduleString (ifaceMod interface) coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString header = case ifaceDoc interface of -- cgit v1.2.3 From 7240b69e3444e40546c7a17855eed2e5ab8a0816 Mon Sep 17 00:00:00 2001 From: Xia Li-yao Date: Tue, 8 Dec 2020 10:43:05 -0500 Subject: Add dangling changes from branches ghc-8.6 and ghc-8.8 (#1243) * Fix multiple typos and inconsistencies in doc/markup.rst Note: I noticed some overlap with #1112 from @wygulmage and #1081 from @parsonsmatt after creating these proposed changes - mea culpa for not looking at the open PRs sooner. * Fix #1113 If no Signatures, no section of index.html * Change the formatting of missing link destinations The current formatting of the missing link destination does not really help user to understand the reasons of the missing link. To address this, I've changed the formatting in two ways: - the missing link symbol name is now fully qualified. This way you immediately know which haskell module cannot be linked. It is then easier to understand why this module does not have documentation (hidden module or broken documentation). - one line per missing link, that's more readable now that symbol name can be longer due to qualification. For example, before haddock was listing missing symbol such as: ``` could not find link destinations for: Word8 Word16 mapMaybe ``` Now it is listed as: ``` could not find link destinations for: - Data.Word.Word8 - Data.Word.Word16 - Data.Maybe.mapMaybe ``` * Add `--ignore-link-symbol` command line argument This argument can be used multiples time. A missing link to a symbol listed by `--ignore-link-symbol` won't trigger "missing link" warning. * Forbid spaces in anchors (#1148) * Improve error messages with context information (#1060) Co-authored-by: Matt Audesse Co-authored-by: Mike Pilgrem Co-authored-by: Guillaume Bouchard Co-authored-by: Pepe Iborra --- doc/markup.rst | 77 ++++++++++++---------- haddock-api/src/Haddock/Backends/Xhtml.hs | 1 + haddock-api/src/Haddock/Interface.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 27 +++++--- haddock-api/src/Haddock/Interface/Rename.hs | 16 +++-- haddock-api/src/Haddock/Options.hs | 10 ++- haddock-api/src/Haddock/Types.hs | 22 ++++++- .../src/Documentation/Haddock/Parser.hs | 2 +- haddock-library/src/Documentation/Haddock/Types.hs | 2 +- .../test/Documentation/Haddock/ParserSpec.hs | 9 ++- 10 files changed, 111 insertions(+), 57 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/doc/markup.rst b/doc/markup.rst index 178a6865..8935b765 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -131,7 +131,7 @@ or like this: :: b -- ^ This is the documentation for the argument of type 'b' There is one edge case that is handled differently: only one ``-- ^`` -annotation occuring after the constructor and all its arguments is +annotation occurring after the constructor and all its arguments is applied to the constructor, not its last argument: :: data T a b @@ -156,8 +156,8 @@ Alternative layout styles are generally accepted by Haddock - for example doc comments can appear before or after the comma in separated lists such as the list of record fields above. -In case that more than one constructor exports a field with the same -name, the documentation attached to the first occurence of the field +In cases where more than one constructor exports a field with the same +name, the documentation attached to the first occurrence of the field will be used, even if a comment is not present. :: data T a = A { someField :: a -- ^ Doc for someField of A @@ -165,7 +165,7 @@ will be used, even if a comment is not present. :: | B { someField :: a -- ^ Doc for someField of B } -In the above example, all occurences of ``someField`` in the +In the above example, all occurrences of ``someField`` in the documentation are going to be documented with ``Doc for someField of A``. Note that Haddock versions 2.14.0 and before would join up documentation of each field and render the result. The @@ -238,7 +238,7 @@ module documentation example and then talk about the fields. :: All fields are optional but they must be in order if they do appear. Multi-line fields are accepted but the consecutive lines have to start -indented more than their label. If your label is indented one space as +indented more than their label. If your label is indented one space, as is often the case with the ``--`` syntax, the consecutive lines have to start at two spaces at the very least. For example, above we saw a multiline ``Copyright`` field: :: @@ -250,7 +250,7 @@ multiline ``Copyright`` field: :: ... -} -That could equivalently be written as :: +That could equivalently be written as: :: -- | ... -- Copyright: @@ -258,14 +258,14 @@ That could equivalently be written as :: -- Someone Else, 2014 -- ... -or as :: +or as: :: -- | ... -- Copyright: (c) Some Person, 2013 -- Someone Else, 2014 -- ... -but not as :: +but not as: :: -- | ... -- Copyright: (c) Some Person, 2013 @@ -352,7 +352,7 @@ Documentation Structure Examples We now give several examples that produce similar results and illustrate most of the structural markup features. The first two -example use an export list, but the third example does not. +examples use an export list, but the third example does not. The first example, using an export list with :ref:`section-headings` and inline section descriptions: :: @@ -362,7 +362,7 @@ and inline section descriptions: :: -- -- | There is a "smart" importer, 'readImage', that determines -- the image format from the file extension, and several - -- "dumb" format-specific importers that decode the file at + -- "dumb" format-specific importers that decode the file as -- the specified type. readImage , readPngImage @@ -417,7 +417,7 @@ defined elsewhere (the ``$imageImporters``; see :ref:`named-chunks`): -- -- There is a "smart" importer, 'readImage', that determines the -- image format from the file extension, and several "dumb" - -- format-specific importers that decode the file at the specified + -- format-specific importers that decode the file as the specified -- type. -- | Read an image, guessing the format from the file name. @@ -450,7 +450,7 @@ The third example, without an export list: :: -- -- There is a "smart" importer, 'readImage', that determines the -- image format from the file extension, and several "dumb" - -- format-specific importers that decode the file at the specified + -- format-specific importers that decode the file as the specified -- type. -- | Read an image, guessing the format from the file name. @@ -522,11 +522,11 @@ create stable links, you can add an explicit anchor (see This will create an HTML anchor ``#g:classes`` to the section. The alternative style of placing the commas at the beginning of each -line is also supported. e.g.: :: +line is also supported, e.g.: :: module Foo ( -- * Classes - , C(..) + C(..) -- * Types -- ** A data type , T @@ -539,7 +539,7 @@ line is also supported. e.g.: :: When not using an export list, you may insert section headers in the module body. Such section headers associate with all entities -declaried up until the next section header. For example: :: +declared up until the next section header. For example: :: module Foo where @@ -614,7 +614,7 @@ re-exporting module. It is often desirable to include a chunk of documentation which is not attached to any particular Haskell declaration, for example, when giving summary documentation for a group of related definitions (see -:ref:`structure-examples`). In addition to including such documenation +:ref:`structure-examples`). In addition to including such documentation chunks at the top of the file, as part of the :ref:`module-description`, you can also associate them with :ref:`section-headings`. @@ -668,14 +668,14 @@ headings, depending on whether you are using an export list or not: -- Here is a large chunk of documentation which may be referred to by -- the name $doc. - Just like with entity declariations when not using an export list, + Just like with entity declarations when not using an export list, named chunks of documentation are associated with the preceding section header here, or with the implicit top-level documentation section if there is no preceding section header. **Warning**: the form used in the first bullet above, where the chunk is not named, *does not work* when you aren't using an - export list. For example :: + export list. For example: :: module Foo where @@ -686,7 +686,7 @@ headings, depending on whether you are using an export list or not: -- | The fooifier. foo :: ... - will result in ``Some documentation not ...`` being attached to + will result in ``Some documentation not ...`` being attached to the *next* entity declaration, here ``foo``, in addition to any other documentation that next entity already has! @@ -756,7 +756,7 @@ type in ``C`` will therefore point locally to ``C.T``. Module Attributes ----------------- -Certain attributes may be specified for each module which affects the +Certain attributes may be specified for each module which affect the way that Haddock generates documentation for that module. Attributes are specified in a comma-separated list in an ``{-# OPTIONS_HADDOCK ... #-}`` pragma at the top of the module, either @@ -807,7 +807,7 @@ Markup Haddock understands certain textual cues inside documentation annotations that tell it how to render the documentation. The cues (or -“markup”) have been designed to be simple and mnemonic in ASCII so that +“markup”) have been designed to be simple and mnemonic in ASCII so the programmer doesn't have to deal with heavyweight annotations when editing documentation comments. @@ -820,8 +820,8 @@ comment. Special Characters ~~~~~~~~~~~~~~~~~~ -The following characters have special meanings in documentation -comments: ``\``, ``/``, ``'``, `````, ``"``, ``@``, ``<``, ``$``, ``#``. To insert a +The following characters have special meanings in documentation comments: +``\``, ``/``, ``'``, `````, ``"``, ``@``, ``<``, ``$``, ``#``. To insert a literal occurrence of one of these special characters, precede it with a backslash (``\``). @@ -839,7 +839,7 @@ Character References Although Haskell source files may contain any character from the Unicode character set, the encoding of these characters as bytes varies between -systems, so that only source files restricted to the ASCII character set +systems. Consequently, only source files restricted to the ASCII character set are portable. Other characters may be specified in character and string literals using Haskell character escapes. To represent such characters in documentation comments, Haddock supports SGML-style numeric character @@ -926,10 +926,11 @@ If ``M.T`` is not otherwise in scope, then Haddock will simply emit a link pointing to the entity ``T`` exported from module ``M`` (without checking to see whether either ``M`` or ``M.T`` exist). -Since values and types live in different namespaces in Haskell, it is -possible for a reference such as ``'X'`` to be ambiguous. In such a case, -Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t`` -(for type) immediately before the link: :: +Since values and types live in different namespaces in Haskell, it is possible +for a reference such as ``'X'`` to be ambiguous. In such a case, Haddock +defaults to pointing to the type. The ambiguity can be overcome by explicitly +specifying a namespace, by way of a ``v`` (for value) or ``t`` (for type) +immediately before the link: :: -- | An implicit reference to 'X', the type constructor -- An explicit reference to v'X', the data constructor @@ -986,7 +987,7 @@ Itemized and Enumerated Lists A bulleted item is represented by preceding a paragraph with either “``*``” or “``-``”. A sequence of bulleted paragraphs is rendered as an -itemized list in the generated documentation, eg.: :: +itemized list in the generated documentation, e.g.: :: -- | This is a bulleted list: -- @@ -1025,7 +1026,7 @@ You can have more than one line of content in a list element: :: You can even nest whole paragraphs inside of list elements. The rules are 4 spaces for each indentation level. You're required to use a -newline before such nested paragraph: :: +newline before such nested paragraphs: :: {-| * Beginning of list @@ -1112,7 +1113,7 @@ followed by the URL enclosed in regular parentheses, for example: :: [some link](http://example.com) -The link text is used as a descriptive text for the URL, if the output +The link text is used as a description for the URL if the output format supports it. Images @@ -1125,8 +1126,8 @@ like this: :: ![image description](pathtoimage.png) If the output format supports it, the image will be rendered inside the -documentation. The image description is used as relpacement text and/or -image title. +documentation. The image description is used as replacement text and/or +an image title. Mathematics / LaTeX ~~~~~~~~~~~~~~~~~~~ @@ -1146,7 +1147,13 @@ the mathematics via `MathJax `__. Grid Tables ~~~~~~~~~~~ -Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. :: +Inspired by reSTs grid tables, Haddock supports a complete table representation +via grid-like "ASCII art". Grid tables are described with a visual grid made +up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for +horizontal lines (row separators). The equals sign ("=") may be used to +separate optional header rows from the table body. The vertical bar ("|") is +used for vertical lines (column separators). The plus sign ("+") is used for +intersections of horizontal and vertical lines. :: -- | This is a grid table: -- @@ -1240,7 +1247,7 @@ Since ^^^^^ ``@since`` annotation can be used to convey information about when the -function was introduced or when it has changed in the way significant to +function was introduced or when it has changed in a way significant to the user. ``@since`` is a paragraph-level element. While multiple such annotations are not an error, only the one to appear in the comment last will be used. ``@since`` has to be followed with a version number, no diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 4e87d0be..f80a9c05 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -307,6 +307,7 @@ ppPrologue pkg qual title (Just doc) = ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppSignatureTree _ _ [] = mempty ppSignatureTree pkg qual ts = divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 66e0bedc..d1e1dae1 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -111,7 +111,7 @@ processModules verbosity modules flags extIfaces = do let warnings = Flag_NoWarnings `notElem` flags dflags <- getDynFlags let (interfaces'', msgs) = - runWriter $ mapM (renameInterface dflags links warnings) interfaces' + runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces' liftIO $ mapM_ putStrLn msgs return (interfaces'', homeLinks) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5a58e1ac..d554eeb3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -39,6 +39,7 @@ import Data.Ord import Control.Applicative import Control.Monad import Data.Traversable +import GHC.Stack (HasCallStack) import Avail hiding (avail) import qualified Avail @@ -58,16 +59,21 @@ import FastString ( unpackFS, bytesFS ) import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O +mkExceptionContext :: TypecheckedModule -> String +mkExceptionContext = + ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule +createInterface :: HasCallStack + => TypecheckedModule -> [Flag] -- Boolean flags -> IfaceMap -- Locally processed modules -> InstIfaceMap -- External, already installed interfaces -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do +createInterface tm flags modMap instIfaceMap = + withExceptionContext (mkExceptionContext tm) $ do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm @@ -207,7 +213,6 @@ createInterface tm flags modMap instIfaceMap = do , ifaceDynFlags = dflags } - -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This @@ -652,7 +657,8 @@ collectDocs = go Nothing [] -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: Bool -- is it a signature + :: HasCallStack + => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package -> Module -- this module @@ -711,7 +717,8 @@ mkExportItems availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool -- is it a signature +availExportItem :: HasCallStack + => Bool -- is it a signature -> IfaceMap -> Module -- this module -> Module -- semantic module @@ -804,7 +811,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just synifiedDecl -> pure synifiedDecl Nothing -> O.pprPanic "availExportItem" (O.text err) - availExportDecl :: AvailInfo -> LHsDecl GhcRn + availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) @@ -1075,7 +1082,8 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam -- This function looks through the declarations in this module to try to find -- the one with the right name. extractDecl - :: DeclMap -- ^ all declarations in the file + :: HasCallStack + => DeclMap -- ^ all declarations in the file -> Name -- ^ name of the declaration to extract -> LHsDecl GhcRn -- ^ parent declaration -> Either ErrMsg (LHsDecl GhcRn) @@ -1159,10 +1167,11 @@ extractDecl declMap name decl _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) +extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> Left "extractPatternSyn: constructor pattern not found" + [] -> Left . O.showSDocUnsafe $ + O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t con:_ -> pure (extract <$> con) where matches :: LConDecl GhcRn -> Bool diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 97f128d7..b4ff31e5 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,6 +29,7 @@ import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) import qualified Data.Map as Map hiding ( Map ) +import qualified Data.Set as Set import Prelude hiding (mapM) -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to @@ -39,8 +40,8 @@ import Prelude hiding (mapM) -- -- The renamed output gets written into fields in the Haddock interface record -- that were previously left empty. -renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface dflags renamingEnv warnings iface = +renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface _dflags ignoredSymbols renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming @@ -75,8 +76,15 @@ renameInterface dflags renamingEnv warnings iface = -- Note that since the renamed AST represents equality constraints as -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to -- manually filter out 'eqTyCon_RDR' (aka @~@). - strings = [ pretty dflags n + + qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n + + ignoreSet = Set.fromList ignoredSymbols + + strings = [ qualifiedName n + | n <- missingNames + , not (qualifiedName n `Set.member` ignoreSet) , not (isSystemName n) , not (isBuiltInSyntax n) , Exact n /= eqTyCon_RDR @@ -88,7 +96,7 @@ renameInterface dflags renamingEnv warnings iface = unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++ - unwords (" " : strings) ] + intercalate "\n\t- " ("" : strings) ] return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 510810b0..8a18a60d 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -36,7 +36,8 @@ module Haddock.Options ( readIfaceArgs, optPackageName, optPackageVersion, - modulePackageInfo + modulePackageInfo, + ignoredSymbols ) where @@ -108,6 +109,7 @@ data Flag | Flag_PackageVersion String | Flag_Reexport String | Flag_SinceQualification String + | Flag_IgnoreLinkSymbol String deriving (Eq, Show) @@ -219,7 +221,9 @@ options backwardsCompat = Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") "version of the package being documented in usual x.y.z.w format", Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL") - "package qualification of @since, one of\n'always' (default) or 'only-external'" + "package qualification of @since, one of\n'always' (default) or 'only-external'", + Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL") + "name of a symbol which does not trigger a warning in case of link issue" ] @@ -336,6 +340,8 @@ verbosity flags = Left e -> throwE e Right v -> v +ignoredSymbols :: [Flag] -> [String] +ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ] ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index ec76fb72..c2cf08bb 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -39,6 +39,7 @@ import Data.Void (Void) import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) +import Exception (ExceptionMonad(..), ghandle) import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt @@ -649,17 +650,28 @@ tell w = Writer ((), w) -- | Haddock's own exception type. -data HaddockException = HaddockException String deriving Typeable +data HaddockException + = HaddockException String + | WithContext [String] SomeException + deriving Typeable instance Show HaddockException where show (HaddockException str) = str - + show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se] throwE :: String -> a instance Exception HaddockException throwE str = throw (HaddockException str) +withExceptionContext :: ExceptionMonad m => String -> m a -> m a +withExceptionContext ctxt = + ghandle (\ex -> + case ex of + HaddockException e -> throw $ WithContext [ctxt] (toException ex) + WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se + ) . + ghandle (throw . WithContext [ctxt]) -- In "Haddock.Interface.Create", we need to gather -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, @@ -694,6 +706,12 @@ instance Monad ErrMsgGhc where instance MonadIO ErrMsgGhc where liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) +instance ExceptionMonad ErrMsgGhc where + gcatch act hand = WriterGhc $ + runWriterGhc act `gcatch` (runWriterGhc . hand) + gmask act = WriterGhc $ gmask $ \mask -> + runWriterGhc $ act (WriterGhc . mask . runWriterGhc) + ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index bd01f354..a3bba38a 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -227,7 +227,7 @@ takeWhile1_ = mfilter (not . T.null) . takeWhile_ -- DocAName "Hello world" anchor :: Parser (DocH mod a) anchor = DocAName . T.unpack <$> - disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") + ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#") -- | Monospaced strings. -- diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index d8c7a9fa..12ccd28d 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -126,7 +126,7 @@ data DocH mod id | DocMathInline String | DocMathDisplay String | DocAName String - -- ^ A (HTML) anchor. + -- ^ A (HTML) anchor. It must not contain any spaces. | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 9bf9b6ea..f264dbba 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -289,8 +289,10 @@ spec = do it "parses a single word anchor" $ do "#foo#" `shouldParseTo` DocAName "foo" - it "parses a multi word anchor" $ do - "#foo bar#" `shouldParseTo` DocAName "foo bar" + -- Spaces are not allowed: + -- https://www.w3.org/TR/html51/dom.html#the-id-attribute + it "doesn't parse a multi word anchor" $ do + "#foo bar#" `shouldParseTo` "#foo bar#" it "parses a unicode anchor" $ do "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ" @@ -305,6 +307,9 @@ spec = do it "does not accept empty anchors" $ do "##" `shouldParseTo` "##" + it "does not accept anchors containing spaces" $ do + "{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}" + context "when parsing emphasised text" $ do it "emphasises a word on its own" $ do "/foo/" `shouldParseTo` DocEmphasis "foo" -- cgit v1.2.3 From 96a60e218b35df611ee56c4bdd8408ec4375e6ca Mon Sep 17 00:00:00 2001 From: tomjaguarpaw Date: Tue, 8 Dec 2020 17:00:04 +0000 Subject: Enable two warnings (#1245) because they will be soon be added to -Wall. See https://gitlab.haskell.org/ghc/ghc/-/issues/15656 --- haddock-api/haddock-api.cabal | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + haddock-api/src/Haddock/GhcUtils.hs | 1 + haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 ++ haddock-api/src/Haddock/Interface/Rename.hs | 1 + haddock-api/src/Haddock/Interface/Specialize.hs | 1 + haddock.cabal | 2 +- 8 files changed, 10 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 4abfd984..5fa51905 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -70,6 +70,8 @@ library -Wredundant-constraints -Wnoncanonical-monad-instances -Wmissing-home-modules + -Wincomplete-uni-patterns + -Wincomplete-record-updates exposed-modules: diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 63acb465..4961edc2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0247d567..0974d6da 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where import Control.Applicative ( Alternative(..) ) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 923516b6..0874e7b4 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 685dca01..ce987b76 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b4ff31e5..78c58581 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 492818bd..6e11a859 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize ( specializeInstHead diff --git a/haddock.cabal b/haddock.cabal index 1d6ad180..0bf99950 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -62,7 +62,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -O2 -threaded + ghc-options: -funbox-strict-fields -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -O2 -threaded -- haddock typically only supports a single GHC major version build-depends: -- cgit v1.2.3 From 39996e2d2ef4b69706bf279a75575bde240b1f1f Mon Sep 17 00:00:00 2001 From: Willem Van Onsem <3482343+KommuSoft@users.noreply.github.com> Date: Tue, 8 Dec 2020 18:26:55 +0100 Subject: simplify calculating percentages fixing #1194 (#1236) --- haddock-api/src/Haddock/Interface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index d1e1dae1..6dcfa594 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -182,7 +182,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = floor (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + percentage = div (haddocked * 100) haddockable modString = moduleString (ifaceMod interface) coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString header = case ifaceDoc interface of -- cgit v1.2.3 From bc962c945af2955402c8bed66ccb310f35a1e676 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 8 Dec 2020 19:42:52 +0100 Subject: Changes for GHC#17566 See https://gitlab.haskell.org/ghc/ghc/merge_requests/2469 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +++- haddock-api/src/Haddock/GhcUtils.hs | 29 +++++++++++++++++++++++--- haddock-api/src/Haddock/Types.hs | 1 + 5 files changed, 32 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 647812f9..024a6c51 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -255,7 +255,7 @@ declNames :: LHsDecl DocNameI , [DocName] -- names being declared ) declNames (L _ decl) = case decl of - TyClD _ d -> (empty, [tcdName d]) + TyClD _ d -> (empty, [tcdNameI d]) SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index f80a9c05..541f40c4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -407,7 +407,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d exportSubs _ = [] exportName :: ExportItem DocNameI -> [IdP DocNameI] - exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) + exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index ef0ba1b6..30b8d43e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -536,6 +536,8 @@ 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 = tcdNameI decl + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- Associated types @@ -794,7 +796,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where - docname = tcdName dataDecl + docname = tcdNameI dataDecl curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 0874e7b4..43fe3e77 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -58,8 +58,7 @@ moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName -getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - HsDecl p -> [IdP p] +getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -221,6 +220,31 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT getGADTConType (XConDecl nec) = noExtCon nec +getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] +getMainDeclBinderI (TyClD _ d) = [tcdNameI d] +getMainDeclBinderI (ValD _ d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinderI (SigD _ d) = sigNameNoLoc d +getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinderI _ = [] + +familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName +familyDeclLNameI (FamilyDecl { fdLName = n }) = n +familyDeclLNameI (XFamilyDecl nec) = noExtCon nec + +tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName +tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd +tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln +tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln +tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln +tyClDeclLNameI (XTyClDecl nec) = noExtCon nec + +tcdNameI :: TyClDecl DocNameI -> DocName +tcdNameI = unLoc . tyClDeclLNameI + -- ------------------------------------- getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) @@ -761,4 +785,3 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty - diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c2cf08bb..853f4b1b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -789,6 +789,7 @@ type instance XDataDecl DocNameI = NoExtField type instance XSynDecl DocNameI = NoExtField type instance XFamDecl DocNameI = NoExtField type instance XXFamilyDecl DocNameI = NoExtCon +type instance XXTyClDecl DocNameI = NoExtCon type instance XHsIB DocNameI _ = NoExtField type instance XHsWC DocNameI _ = NoExtField -- cgit v1.2.3 From 02769a1fb005c68199b16f350e649464a346bd48 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 8 Dec 2020 20:03:49 +0100 Subject: Import intercalate --- haddock-api/src/Haddock/Interface/Rename.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 78c58581..4d9eadac 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,6 +29,7 @@ import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) +import Data.List (intercalate) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set import Prelude hiding (mapM) -- cgit v1.2.3 From 8dcc6d652c434b6ed9aea7a6019447aa72e7ba28 Mon Sep 17 00:00:00 2001 From: Matthías Páll Gissurarson Date: Fri, 19 Jun 2020 17:47:48 +0200 Subject: Adapt Haddock for QualifiedDo --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0974d6da..285b0ee7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -176,7 +176,7 @@ classify tok = ITdata -> TkKeyword ITdefault -> TkKeyword ITderiving -> TkKeyword - ITdo -> TkKeyword + ITdo {} -> TkKeyword ITelse -> TkKeyword IThiding -> TkKeyword ITforeign -> TkKeyword @@ -209,7 +209,7 @@ classify tok = ITcapiconv -> TkKeyword ITprimcallconv -> TkKeyword ITjavascriptcallconv -> TkKeyword - ITmdo -> TkKeyword + ITmdo {} -> TkKeyword ITfamily -> TkKeyword ITrole -> TkKeyword ITgroup -> TkKeyword -- cgit v1.2.3